From ed1bd5f4a50d8a086bfa8be55ae491b2c1bbf997 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Thu, 30 Apr 2020 18:34:23 -0400 Subject: [PATCH 001/256] "Barotropic velocity tendency" diagnostic added --- src/core/MOM_barotropic.F90 | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5f97f5933a..6eef429f92 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -294,6 +294,7 @@ module MOM_barotropic integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1 integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1 integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1 + integer :: id_ubtdt = -1, id_vbtdt = -1 integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1 integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1 integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1 @@ -479,6 +480,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1]. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. + ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + ubt_dt, & ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains ! after a time step, the remainder being lost to bottom drag. ! bt_rem_u is a nondimensional number between 0 and 1. @@ -512,6 +515,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1]. + vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + vbt_dt, & ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_v, & ! The fraction of the barotropic meridional velocity that ! remains after a time step, the rest being lost to bottom ! drag. bt_rem_v is a nondimensional number between 0 and 1. @@ -1479,6 +1484,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=1) endif + if (CS%id_ubtdt > 0) then + ubt_st(:,:) = ubt(:,:) + endif + + if (CS%id_vbtdt > 0) then + vbt_st(:,:) = vbt(:,:) + endif + if (query_averaging_enabled(CS%diag)) then if (CS%id_eta_st > 0) call post_data(CS%id_eta_st, eta(isd:ied,jsd:jed), CS%diag) if (CS%id_ubt_st > 0) call post_data(CS%id_ubt_st, ubt(IsdB:IedB,jsd:jed), CS%diag) @@ -2201,6 +2214,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo call post_data(CS%id_Corv_bt, Corv_bt_sum(isd:ied,JsdB:JedB), CS%diag) endif + if (CS%id_ubtdt > 0) then + do j=js,je ; do I=is-1,ie + ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))/dt + enddo ; enddo + call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag) + endif + if (CS%id_vbtdt > 0) then + do J=js-1,je ; do i=is,ie + vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))/dt + enddo ; enddo + call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag) + endif + if (CS%id_ubtforce > 0) call post_data(CS%id_ubtforce, BT_force_u(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vbtforce > 0) call post_data(CS%id_vbtforce, BT_force_v(isd:ied,JsdB:JedB), CS%diag) if (CS%id_uaccel > 0) call post_data(CS%id_uaccel, u_accel_bt(IsdB:IedB,jsd:jed), CS%diag) @@ -4203,6 +4229,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Barotropic zonal acceleration from baroclinic terms', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, Time, & 'Barotropic meridional acceleration from baroclinic terms', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ubtdt = register_diag_field('ocean_model', 'ubt_dt', diag%axesCu1, Time, & + 'Barotropic zonal acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_vbtdt = register_diag_field('ocean_model', 'vbt_dt', diag%axesCv1, Time, & + 'Barotropic meridional acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, Time, & 'Barotropic end SSH', thickness_units, conversion=GV%H_to_m) From badd68186080135bc086c0f06c80f74357e77286 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Mon, 11 May 2020 13:44:57 -0400 Subject: [PATCH 002/256] Changed the division by dt to multiplication form --- src/core/MOM_barotropic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9eb7a9d2e0..c2a9b3c8b1 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2315,13 +2315,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%id_ubtdt > 0) then do j=js,je ; do I=is-1,ie - ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))/dt + ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))*Idt enddo ; enddo call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag) endif if (CS%id_vbtdt > 0) then do J=js-1,je ; do i=is,ie - vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))/dt + vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))*Idt enddo ; enddo call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag) endif From 42a9eaffa6c0c11182f25495176da83e938d97cc Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Sat, 16 May 2020 22:19:36 -0400 Subject: [PATCH 003/256] Changed the array intilization to standard halos instead of wide halos for variables used in computing barotropic velocity tendency terms --- src/core/MOM_barotropic.F90 | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c2a9b3c8b1..ee90dc1d67 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -477,10 +477,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! sums less than one due to viscous losses. Nondimensional. real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u, nondimensional. - tmp_u ! A temporary array at u points. + tmp_u, & ! A temporary array at u points. + ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + ubt_dt ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJB_(G)) :: & av_rem_v, & ! The weighted average of visc_rem_v, nondimensional. - tmp_v ! A temporary array at v points. + tmp_v, & ! A temporary array at v points. + vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & e_anom ! The anomaly in the sea surface height or column mass ! averaged between the beginning and end of the time step, @@ -491,8 +495,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! 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]. - ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. - ubt_dt, & ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. + ! ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + ! ubt_dt, & ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains ! after a time step, the remainder being lost to bottom drag. ! bt_rem_u is a nondimensional number between 0 and 1. @@ -526,8 +530,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1]. - vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. - vbt_dt, & ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. +! vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. +! vbt_dt, & ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_v, & ! The fraction of the barotropic meridional velocity that ! remains after a time step, the rest being lost to bottom ! drag. bt_rem_v is a nondimensional number between 0 and 1. @@ -1553,11 +1557,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%id_ubtdt > 0) then - ubt_st(:,:) = ubt(:,:) + do j=js-1,je+1 ; do I=is-1,ie + ubt_st(I,j) = ubt(I,j) + enddo ; enddo endif if (CS%id_vbtdt > 0) then - vbt_st(:,:) = vbt(:,:) + do J=js-1,je ; do i=is-1,ie+1 + vbt_st(i,J) = vbt(i,J) + enddo ; enddo endif if (query_averaging_enabled(CS%diag)) then From e261b421f9d3c435923219b477633dff21157107 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Sat, 16 May 2020 22:25:23 -0400 Subject: [PATCH 004/256] Removed unused variables --- src/core/MOM_barotropic.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index ee90dc1d67..7bb03dd2cf 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -495,8 +495,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! 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]. - ! ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. - ! ubt_dt, & ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains ! after a time step, the remainder being lost to bottom drag. ! bt_rem_u is a nondimensional number between 0 and 1. @@ -530,8 +528,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1]. -! vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. -! vbt_dt, & ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. bt_rem_v, & ! The fraction of the barotropic meridional velocity that ! remains after a time step, the rest being lost to bottom ! drag. bt_rem_v is a nondimensional number between 0 and 1. From 6ef10ffc8fb4425b48125a457bce22c4e0af52d5 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Mon, 18 May 2020 09:54:54 -0400 Subject: [PATCH 005/256] Removed white space --- src/core/MOM_barotropic.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7bb03dd2cf..f63ab42669 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1557,7 +1557,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_st(I,j) = ubt(I,j) enddo ; enddo endif - if (CS%id_vbtdt > 0) then do J=js-1,je ; do i=is-1,ie+1 vbt_st(i,J) = vbt(i,J) From 2befa56093270b5eb318d6089812904b394f63bf Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Mon, 18 May 2020 15:01:27 -0400 Subject: [PATCH 006/256] Trailing white spaces removed --- src/core/MOM_barotropic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f63ab42669..e6f11987a2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1553,8 +1553,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%id_ubtdt > 0) then - do j=js-1,je+1 ; do I=is-1,ie - ubt_st(I,j) = ubt(I,j) + do j=js-1,je+1 ; do I=is-1,ie + ubt_st(I,j) = ubt(I,j) enddo ; enddo endif if (CS%id_vbtdt > 0) then From c907001567da3376db30a25365d8974cebb679a7 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 19 May 2020 17:15:25 -0400 Subject: [PATCH 007/256] Rotate: fixed-time ALE sponge bugfixes The sp_val and sp_val_in fields were only allocated for fixed-time sponges (fixed_sponge=.true.) but were being referenced regardless of this flag in a few cases. On x86 architectures this did not create any errors, but was detected on an Arm64 CPU. This patch correctly moves all code associated with these variables into a flag-enabled block. --- .../vertical/MOM_ALE_sponge.F90 | 32 +++++++++++-------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index fe1ccab53d..70914a69ad 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -1047,9 +1047,11 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) 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) @@ -1080,15 +1082,22 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) 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 - 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 + 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) + do k=1,nz_data + sp_val_in(c_i, c_j, k) = sponge_in%Ref_val(n)%p(k,c) + enddo + enddo + + call rotate_array(sp_val_in, turns, sp_val) + ! NOTE: This points sp_val with the unrotated field. See note below. call set_up_ALE_sponge_field(sp_val, G, sp_ptr, sponge) + + deallocate(sp_val_in) 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 @@ -1118,11 +1127,6 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) 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 " & From 5c0dc48a04d1e96f5eb0c82797f59f929789ac95 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 19 May 2020 17:20:40 -0400 Subject: [PATCH 008/256] Rotate: ALE sponge whitespace fix --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 70914a69ad..438236fc2a 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -1048,7 +1048,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) 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 + do k = 1, nz_data data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) enddo endif @@ -1084,10 +1084,10 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) sp_ptr => sponge_in%var(n)%p if (fixed_sponge) then sp_val_in(:,:,:) = 0.0 - 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) - do k=1,nz_data + do k = 1, nz_data sp_val_in(c_i, c_j, k) = sponge_in%Ref_val(n)%p(k,c) enddo enddo From fd4a47d7b70ed31a6a2486d271758a163a123d5b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 20 May 2020 11:01:32 -0400 Subject: [PATCH 009/256] Travis: Arm64 tests; git depth restored; Makefile There are four minor changes in this patch: - Arm64 testing has been enabled on Travis. As a non-x86 architecture, this will provide more robust testing of the code. - Travis MPI library switch to MPICH There were issues with using OpenMPI on Arm64, particularly with MPI_Init. Switching to MPICH appeared to resolve those issues, and MPICH has a much simpler implementation, so we've switched all jobs to it. - default git depth has been restored Our regression testing method no longer requires a complete history for comparison. - Makefile fix: dimension now reported in summary The test.summary output now includes the dimension type in the list of failed tests. --- .testing/Makefile | 6 +++--- .travis.yml | 23 +++++++++++++++++------ 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 66a116a32a..d38189667b 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -378,17 +378,17 @@ test.summary: 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]}' ; \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ 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]}' ; \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ 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]}' ; \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ fi; \ false ; \ else \ diff --git a/.travis.yml b/.travis.yml index 6b0b4c2a5e..4ceab0a438 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,19 +5,16 @@ language: c dist: bionic -# --depth flag is breaking our merge, try disabling it -# NOTE: We may be able to go back to depth=50 in production -git: - depth: false - addons: apt: sources: - ubuntu-toolchain-r-test packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev openmpi-bin libopenmpi-dev gfortran + - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev gfortran + - mpich libmpich-dev - doxygen graphviz flex bison cmake - python-numpy python-netcdf4 + - bc jobs: include: @@ -58,3 +55,17 @@ jobs: - echo -en 'travis_fold:end:script.1\\r' - make -k -s test.regressions - make test.summary + + - arch: arm64 + env: + - JOB="Configuration testing" + - DO_REGRESSION_TESTS=false + - DO_REPRO_TESTS=false + - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + script: + - cd .testing + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - make all + - echo -en 'travis_fold:end:script.1\\r' + - make -k -s test + - make test.summary From 2baaea7cd580aa9539d4eb4f0dbf5f2ccbae7821 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 20 May 2020 11:21:45 -0400 Subject: [PATCH 010/256] Travis: Renaming jobs to reflect architecture --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4ceab0a438..6bf509ce8c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,7 @@ jobs: - test ! -s doxy_errors - env: - - JOB="Configuration testing" + - JOB="x86 Configuration testing" - DO_REGRESSION_TESTS=false - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk script: @@ -42,7 +42,7 @@ jobs: # NOTE: Code coverage upload is here to reduce load imbalance - if: type = pull_request env: - - JOB="Regression testing" + - JOB="x86 Regression testing" - DO_REGRESSION_TESTS=true - REPORT_COVERAGE=true - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk @@ -58,7 +58,7 @@ jobs: - arch: arm64 env: - - JOB="Configuration testing" + - JOB="ARM64 Configuration testing" - DO_REGRESSION_TESTS=false - DO_REPRO_TESTS=false - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk From 7369c39dd13a87e2f6077e5a40b2cb415a111174 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 May 2020 20:11:54 -0400 Subject: [PATCH 011/256] +Add just_read_params arg to entrain_diffusive_init Added the new optional argument just_read_params to entrain_diffusive_init, which if present and true causes this routine to read the parameters used by the entrain_diffusive module without logging them. Also set this new parameter based on whether ALE remapping is being used. This prevents the diagnostics and parameters from this module from being offered or logged when they are not actually available, and it will prevent the parameter CORRECT_DENSITY from being logged in ALE-configured runs. All answers are bitwise identical, but there are changes in some MOM_parameter_doc and available_diags files. --- .../vertical/MOM_diabatic_driver.F90 | 14 ++---- .../vertical/MOM_entrain_diffusive.F90 | 47 ++++++++++--------- 2 files changed, 30 insertions(+), 31 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d753afc97b..0bd3138670 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2273,11 +2273,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif - ! This block sets ea, eb from Kd or Kd_int. - ! Otherwise, call entrainment_diffusive() which sets ea and eb - ! based on KD and target densities (ie. does remapping as well). - ! When not using ALE, calculate layer entrainments/detrainments from - ! diffusivities and differences between layer and target densities + ! Calculate layer entrainments and detrainments from diffusivities and differences between + ! layer and target densities (i.e. do remapping as well as diffusion). call cpu_clock_begin(id_clock_entrain) ! Calculate appropriately limited diapycnal mass fluxes to account ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb @@ -3688,7 +3685,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! False. CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_csp) - call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp) + call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp, & + just_read_params=CS%useALEalgorithm) ! initialize the geothermal heating module if (CS%use_geothermal) & @@ -3763,12 +3761,10 @@ subroutine diabatic_driver_end(CS) call entrain_diffusive_end(CS%entrain_diffusive_CSp) call set_diffusivity_end(CS%set_diff_CSp) - if (CS%useKPP) then + if (CS%useKPP) then deallocate( CS%KPP_buoy_flux ) deallocate( CS%KPP_temp_flux ) deallocate( CS%KPP_salt_flux ) - endif - if (CS%useKPP) then deallocate( CS%KPP_NLTheat ) deallocate( CS%KPP_NLTscalar ) call KPP_end(CS%KPP_CSp) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 4e30756f7b..1be3421534 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -2081,7 +2081,7 @@ end subroutine find_maxF_kb !> This subroutine initializes the parameters and memory associated with the !! entrain_diffusive module. -subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) +subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_read_params) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -2092,18 +2092,15 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) !! output. type(entrain_diffusive_CS), pointer :: CS !< A pointer that is set to point to the control !! structure. -! for this module -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + logical, optional, intent(in) :: just_read_params !< If present and true, this call will + !! only read parameters logging them or registering + !! any diagnostics + + ! Local variables real :: decay_length, dt, Kd -! This include declares and sets the variable "version". -#include "version_variable.h" + logical :: just_read ! If true, just read parameters but do nothing else. + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. if (associated(CS)) then @@ -2113,37 +2110,43 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) endif allocate(CS) + just_read = .false. ; if (present(just_read_params)) just_read = just_read_params + CS%diag => diag CS%bulkmixedlayer = (GV%nkml > 0) ! Set default, read and log parameters - call log_version(param_file, mdl, version, "") + if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "CORRECT_DENSITY", CS%correct_density, & "If true, and USE_EOS is true, the layer densities are "//& "restored toward their target values by the diapycnal "//& "mixing, as described in Hallberg (MWR, 2000).", & - default=.true.) + default=.true., do_not_log=just_read) call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& - "calculate the interior diapycnal entrainment.", default=5) + "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true.) + fail_if_missing=.true., do_not_log=just_read) ! CS%Tolerance_Ent = MAX(100.0*GV%Angstrom_H,1.0e-4*sqrt(dt*Kd)) ! call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H) + units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, do_not_log=just_read) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R - 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%RZ3_T3_to_W_m2) + if (.not.just_read) then + 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%RZ3_T3_to_W_m2) + endif + + if (just_read) deallocate(CS) end subroutine entrain_diffusive_init From 64651d5f3ae290928a4c67bac68b0ff119a19402 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 21 May 2020 15:32:09 -0400 Subject: [PATCH 012/256] CodeCov: Set number of reports to 8 This setting will prevent CodeCov from updating the repository until all 8 test suites are completed. The number is fixed to 8 in the file, so we now need to keep these in sync until this can be sorted out some other way. --- .codecov.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.codecov.yml b/.codecov.yml index 576633bf6a..05fe474ab3 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -6,3 +6,6 @@ coverage: patch: default: threshold: 100% +comment: + # This must be set to the number of test cases (TCs) + after_n_builds: 8 From eb28c73a57763b0a7a4c32704b168b085c547693 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 22 May 2020 15:35:44 +0000 Subject: [PATCH 013/256] Switch to intel/18 on gaea - The compiler versions used in the gaea pipelines are encoded in the MRS package of scripts. This commit switches to the master branch which will now pull the latest version of MRS. --- .gitlab-ci.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39b63c8f85..5a05694fef 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,13 +32,11 @@ setup: - git clone --recursive http://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests && cd tests # Install / update testing scripts - git clone https://github.com/adcroft/MRS.git MRS - - (cd MRS ; git checkout xanadu-fms) # Update MOM6-examples and submodules - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) - (cd MOM6-examples/src/MOM6 && git submodule update) - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - #- (cd MOM6-examples/src/mkmf && git pull https://github.com/adcroft/mkmf.git add_coverage_mode) - env > gitlab_session.log # Cache everything under tests to unpack for each subsequent stage - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests From 7c3750d8477359836bef90f60d9b178af2b9c442 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 22 May 2020 15:00:47 -0400 Subject: [PATCH 014/256] Codecov: Set base as parent (target) branch Codecov appears to have two schemes for setting a target reference for coverage measurements: `pr` and `parent`. The first seems to measure coverage relative to the point where the PR was branched to branch against the current state of the PR. The second measures coverage relative to the current state of branch to be merged against the merged PR conent PR submissions default to the first, but we want to measure coverage relative to the second. This patch always uses the `parent` method. --- .codecov.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.codecov.yml b/.codecov.yml index 05fe474ab3..84e438145e 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -3,9 +3,11 @@ coverage: project: default: threshold: 100% + base: parent patch: default: threshold: 100% + base: parent comment: # This must be set to the number of test cases (TCs) after_n_builds: 8 From 33c3bf98f8ee2ba2fa6a158d43b3984cdfa7039c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 24 May 2020 11:57:05 -0800 Subject: [PATCH 015/256] Added a space to a description. --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index eedd9e9268..e5a4b3de8a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1063,7 +1063,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "If true, use an alternative formula for computing the (equilibrium)"//& "initial value of MEKE.", default=.false.) call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & - "If true, restore MEKE back to its equilibrium value, which is calculated at"//& + "If true, restore MEKE back to its equilibrium value, which is calculated at "//& "each time step.", default=.false.) if (CS%MEKE_equilibrium_restoring) then call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & From fc0da5058c590e10e21a4d766e25666ce1620def Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 25 May 2020 15:41:25 -0800 Subject: [PATCH 016/256] Clean up some divide-by-zero issues in OBCs. --- src/core/MOM_open_boundary.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5b6dc168f4..32f9936f4d 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4766,8 +4766,8 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) segment=>OBC%segment(n) if (.not. associated(segment%tr_Reg)) cycle if (segment%is_E_or_W) then + I = segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - I = segment%HI%IsdB ! ishift+I corresponds to the nearest interior tracer cell index ! idir switches the sign of the flow so that positive is into the reservoir if (segment%direction == OBC_DIRECTION_W) then @@ -4775,8 +4775,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) else ishift = 0 ; idir = 1 endif + if (G%mask2dT(I+ishift,j) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + if (h(i+ishift,j,k) == 0.0) cycle u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) fac1 = 1.0 + (u_L_out-u_L_in) @@ -4787,8 +4789,8 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) enddo ; endif ; enddo enddo else + J = segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - J = segment%HI%JsdB ! jshift+J corresponds to the nearest interior tracer cell index ! jdir switches the sign of the flow so that positive is into the reservoir if (segment%direction == OBC_DIRECTION_S) then @@ -4796,8 +4798,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) else jshift = 0 ; jdir = 1 endif + if (G%mask2dT(i,j+jshift) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + if (h(i,j+jshift,k) == 0.0) cycle v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) From 8a5ca12f8a6462276eaf14af1368d760a50bb510 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 26 May 2020 14:54:17 -0800 Subject: [PATCH 017/256] Alternate fix for divide-by-zero. --- src/core/MOM_open_boundary.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 32f9936f4d..69a0adbf25 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4775,12 +4775,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) else ishift = 0 ; idir = 1 endif + ! Can keep this or take it out, either way if (G%mask2dT(I+ishift,j) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - if (h(i+ishift,j,k) == 0.0) cycle - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = 1.0 + (u_L_out-u_L_in) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & @@ -4798,12 +4800,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) else jshift = 0 ; jdir = 1 endif + ! Can keep this or take it out, either way if (G%mask2dT(i,j+jshift) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - if (h(i,j+jshift,k) == 0.0) cycle - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & From 41f57c088208aa3832b852f5b664562dff657d28 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 29 May 2020 17:31:28 -0400 Subject: [PATCH 018/256] (*)Improve ePBL when EPBL_ORIGINAL_PE_CALC=False Modified ePBL_column to calculate Te and Se when EPBL_ORIGINAL_PE_CALC is False and there are no temperature change diagnostics being requested, and to return dPEc_dKd from one of the calls to find_PE_chg. This avoids the use of uninitialized values in EPBL_ORIGINAL_PE_CALC is false, and some solutions appear to be similar, but others give large qualitative changes, so there are probably still problems with EPBL_ORIGINAL_PE_CALC = False. When this was originally developed, it was verified to be mathematically equivalent, but in the years that this code was not tested, problems have crept it. All answers in the MOM6-examples test cases are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 25e1f80ff0..e3c33bd1c8 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -772,7 +772,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs integer :: OBL_it ! Iteration counter real :: Surface_Scale ! Surface decay scale for vstar - + logical :: calc_dT_expect ! If true calculate the expected changes in temperature and salinity. + logical :: calc_Te ! If true calculate the expected final temperature and salinity values. logical :: debug=.false. ! Change this hard-coded value for debugging. ! The following arrays are used only for debugging purposes. @@ -788,7 +789,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (.not. associated(CS)) call MOM_error(FATAL, "energetic_PBL: "//& "Module must be initialized before it is used.") - debug = .false. ; if (allocated(eCD%dT_expect) .or. allocated(eCD%dS_expect)) debug = .true. + calc_dT_expect = debug ; if (allocated(eCD%dT_expect) .or. allocated(eCD%dS_expect)) calc_dT_expect = .true. + calc_Te = (calc_dT_expect .or. (.not.CS%orig_PE_calc)) h_neglect = GV%H_subroundoff @@ -1285,7 +1287,7 @@ 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), 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=dPE_conv) + PE_chg=dPE_conv, dPEc_dKd=dPEc_dKd) endif MKE_src = dMKE_max * (1.0 - exp(-MKE2_Hharm * Kddt_h_guess)) dMKE_src_dK = dMKE_max * MKE2_Hharm * exp(-MKE2_Hharm * Kddt_h_guess) @@ -1381,7 +1383,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs htot = htot + h(k) endif - if (debug) then + if (calc_Te) then if (k==2) then Te(1) = b1*(h(1)*T0(1)) Se(1) = b1*(h(1)*S0(1)) @@ -1393,7 +1395,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs enddo Kd(nz+1) = 0.0 - if (debug) then + if (calc_dT_expect) then ! Complete the tridiagonal solve for Te. b1 = 1.0 / hp_a Te(nz) = b1 * (h(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) @@ -1404,7 +1406,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs Se(k) = Se(k) + c1(K+1)*Se(k+1) eCD%dT_expect(k) = Te(k) - T0(k) ; eCD%dS_expect(k) = Se(k) - S0(k) enddo + endif + if (debug) then dPE_debug = 0.0 do k=1,nz dPE_debug = dPE_debug + (dT_to_dPE(k) * (Te(k) - T0(k)) + & From 0ee031d342761484f8c81132e60a4a9550cdd035 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 May 2020 10:54:14 -0400 Subject: [PATCH 019/256] Added explicit form of cpu_clock_id Added an explicit MOM6 interface for cpu_clock_id, rather than simply passing the call through to mpp_clock_id, both to explicitly document the interface and arguments and to use the FMS run-time defaults for clock synchronization. This will enable SIS2 to use the MOM_cpu_clock module with the same behavior. All answers and output are bitwise identical. --- src/framework/MOM_cpu_clock.F90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index 41849aafb7..a041b06b8b 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -3,8 +3,9 @@ module MOM_cpu_clock ! This file is part of MOM6. See LICENSE.md for the license. +use fms_mod, only : clock_flag_default use mpp_mod, only : cpu_clock_begin => mpp_clock_begin -use mpp_mod, only : cpu_clock_end => mpp_clock_end, cpu_clock_id => mpp_clock_id +use mpp_mod, only : cpu_clock_end => mpp_clock_end, mpp_clock_id use mpp_mod, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER use mpp_mod, only : CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA use mpp_mod, only : CLOCK_SYNC => MPP_CLOCK_SYNC @@ -15,4 +16,27 @@ module MOM_cpu_clock public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA, CLOCK_SYNC +contains + +!> cpu_clock_id returns the integer handle for a named CPU clock. +function cpu_clock_id( name, synchro_flag, grain ) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs + !! are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is odd, while additional (expensive) statistics can set + !! for other values. If absent, the default is taken from the + !! settings for FMS. + integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + integer :: cpu_clock_id !< The integer CPU clock handle. + + if (present(synchro_flag)) then + cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) + else + cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) + endif + +end function cpu_clock_id + end module MOM_cpu_clock From e0af94c3f26292a783c1c654167cfea21dab6e64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 May 2020 11:02:24 -0400 Subject: [PATCH 020/256] +Added code to handle tab lengths in documentation Added code to handle discrepancies between compliers in how "\t" is handled in strings, so that the MOM6 documentation files are identical across compilers. All answers are bitwise identical. --- src/framework/MOM_document.F90 | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 6c4c1f1ebb..b7fa6a170c 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -468,6 +468,8 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & integer :: start_ind = 1 ! The starting index in the description for the next line. integer :: nl_ind, tab_ind, end_ind ! The indices of new-lines, tabs, and the end of a line. integer :: len_text, len_tab, len_nl ! The lengths of the text string, tabs and new-lines. + integer :: len_cor ! The permitted length corrected for tab sizes in a line. + integer :: substr_start ! The starting index of a substring to search for tabs. integer :: indnt, msg_pad ! Space counts used to format a message. logical :: msg_done, reset_msg_pad ! Logicals used to format messages. logical :: all, short, layout, debug ! Flags indicating which files to write into. @@ -494,16 +496,25 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & do if (len_trim(desc(start_ind:)) < 1) exit - nl_ind = index(desc(start_ind:), "\n") + len_cor = len_text - msg_pad + substr_start = start_ind + do ! Adjust the available line length for anomalies in the size of tabs + tab_ind = index(desc(substr_start:start_ind+len_cor), "\t") ! Count \t as 2 spaces. + if (tab_ind == 0) exit + substr_start = substr_start + tab_ind + len_cor = len_cor + (len_tab - 2) + enddo + + nl_ind = index(desc(start_ind:), "\n") end_ind = 0 - if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_text-msg_pad)) then + if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_cor)) then ! This line is too long despite the new-line character. Look for an earlier space to break. - end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + end_ind = scan(desc(start_ind:start_ind+(len_cor)), " ", back=.true.) - 1 if (end_ind > 0) nl_ind = 0 - elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_text-msg_pad)) then + elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_cor)) then ! This line is too long and does not have a new-line character. Look for a space to break. - end_ind = scan(desc(start_ind:start_ind+(len_text-msg_pad)), " ", back=.true.) - 1 + end_ind = scan(desc(start_ind:start_ind+(len_cor)), " ", back=.true.) - 1 endif reset_msg_pad = .false. From 3303fb9d4597c211698d44f441dc3da432f10122 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 May 2020 11:13:56 -0400 Subject: [PATCH 021/256] Included H_subroundoff in a denominator Added an H_subroundoff term to the denominator of an expression in calculate_bkgnd_mixing for the inverse of the mixed layer thickness, so that NaNs will not be created when taking this inverse if CS%HMix is set to 0. All answers are bitwise identical in the MOM6-examples test cases. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 57199f38d0..779bee6fcf 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -445,7 +445,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) elseif ((.not. CS%Bryan_Lewis_diffusivity) .and. (.not.CS%bulkmixedlayer) .and. & (.not. CS%horiz_varying_background) .and. (CS%Kd /= CS%Kdml)) then - I_Hmix = 1.0 / CS%Hmix + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) From 64827718bc1674d496960807abe2c5a316e39e46 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 May 2020 15:53:09 -0400 Subject: [PATCH 022/256] Corrected recent bug in writeMessageAndDesc Minor correction to avoid scanning past the end of a string. With sensitive settings, this bug was causing sensitive models to abort, but if the model ran it was giving bitwise identical answers. --- src/framework/MOM_document.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index b7fa6a170c..610cc5eb63 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -500,6 +500,7 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & substr_start = start_ind do ! Adjust the available line length for anomalies in the size of tabs + if (len_trim(desc) <= start_ind+len_cor) exit ! This line will not span another line. tab_ind = index(desc(substr_start:start_ind+len_cor), "\t") ! Count \t as 2 spaces. if (tab_ind == 0) exit substr_start = substr_start + tab_ind @@ -510,11 +511,11 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & end_ind = 0 if ((nl_ind > 0) .and. (len_trim(desc(start_ind:start_ind+nl_ind-2)) > len_cor)) then ! This line is too long despite the new-line character. Look for an earlier space to break. - end_ind = scan(desc(start_ind:start_ind+(len_cor)), " ", back=.true.) - 1 + end_ind = scan(desc(start_ind:start_ind+len_cor), " ", back=.true.) - 1 if (end_ind > 0) nl_ind = 0 elseif ((nl_ind == 0) .and. (len_trim(desc(start_ind:)) > len_cor)) then ! This line is too long and does not have a new-line character. Look for a space to break. - end_ind = scan(desc(start_ind:start_ind+(len_cor)), " ", back=.true.) - 1 + end_ind = scan(desc(start_ind:start_ind+len_cor), " ", back=.true.) - 1 endif reset_msg_pad = .false. From 6e569173cea5e4bd3fbb4c59b49d64a2e36ccf24 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 May 2020 07:39:03 -0400 Subject: [PATCH 023/256] Slight improvement in writeMessageAndDesc Slight revision to writeMessageAndDesc to handle the case when a change in tab spacing will cause a line to exactly the maximum line length. All answers are bitwise identical answers. --- src/framework/MOM_document.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 610cc5eb63..b122a5b6f0 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -469,6 +469,7 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & integer :: nl_ind, tab_ind, end_ind ! The indices of new-lines, tabs, and the end of a line. integer :: len_text, len_tab, len_nl ! The lengths of the text string, tabs and new-lines. integer :: len_cor ! The permitted length corrected for tab sizes in a line. + integer :: len_desc ! The non-whitespace length of the description. integer :: substr_start ! The starting index of a substring to search for tabs. integer :: indnt, msg_pad ! Space counts used to format a message. logical :: msg_done, reset_msg_pad ! Logicals used to format messages. @@ -499,9 +500,10 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & len_cor = len_text - msg_pad substr_start = start_ind - do ! Adjust the available line length for anomalies in the size of tabs - if (len_trim(desc) <= start_ind+len_cor) exit ! This line will not span another line. - tab_ind = index(desc(substr_start:start_ind+len_cor), "\t") ! Count \t as 2 spaces. + len_desc = len_trim(desc) + do ! Adjust the available line length for anomalies in the size of tabs, counting \t as 2 spaces. + if (substr_start >= start_ind+len_cor) exit + tab_ind = index(desc(substr_start:min(len_desc,start_ind+len_cor)), "\t") if (tab_ind == 0) exit substr_start = substr_start + tab_ind len_cor = len_cor + (len_tab - 2) From dc969f893386ee9cdcac93b0f4bbcf9636fffdb4 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 2 Jun 2020 02:42:09 +0000 Subject: [PATCH 024/256] Renamed Neverland to Neverworld - Modules, routines and labels in code changed from Neverland to Neverworld. - Add aliases for parameters so that existing configurations still work (given that Neverworld was published but the runs used Neverland). --- .../solo_driver/MOM_surface_forcing.F90 | 18 +++---- ...ing.F90 => Neverworld_surface_forcing.F90} | 54 +++++++++---------- .../MOM_fixed_initialization.F90 | 6 +-- .../MOM_state_initialization.F90 | 6 +-- ...tion.F90 => Neverworld_initialization.F90} | 30 +++++------ 5 files changed, 57 insertions(+), 57 deletions(-) rename config_src/solo_driver/{Neverland_surface_forcing.F90 => Neverworld_surface_forcing.F90} (87%) rename src/user/{Neverland_initialization.F90 => Neverworld_initialization.F90} (89%) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 173d417ff3..152cfb4b85 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -39,8 +39,8 @@ module MOM_surface_forcing use MOM_variables, only : surface use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS -use Neverland_surface_forcing, only : Neverland_wind_forcing, Neverland_buoyancy_forcing -use Neverland_surface_forcing, only : Neverland_surface_forcing_init, Neverland_surface_forcing_CS +use Neverworld_surface_forcing, only : Neverworld_wind_forcing, Neverworld_buoyancy_forcing +use Neverworld_surface_forcing, only : Neverworld_surface_forcing_init, Neverworld_surface_forcing_CS use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init @@ -204,7 +204,7 @@ module MOM_surface_forcing type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() + type(Neverworld_surface_forcing_CS), pointer :: Neverworld_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() !>@} @@ -280,8 +280,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, US, CS) elseif (trim(CS%wind_config) == "const") then call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverland_forcing_CSp) + elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverworld_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -314,8 +314,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "Neverland") then - call Neverland_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverland_forcing_CSp) + elseif (trim(CS%buoy_config) == "Neverworld" .or. trim(CS%buoy_config) == "Neverland") then + call Neverworld_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverworld_forcing_CSp) elseif (trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%buoy_config) == "USER") then @@ -1756,8 +1756,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, US, param_file, diag, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverland_forcing_CSp) + elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call Neverworld_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverworld_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr" .or.& trim(CS%wind_config) == "SCM_ideal_hurr") then call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverworld_surface_forcing.F90 similarity index 87% rename from config_src/solo_driver/Neverland_surface_forcing.F90 rename to config_src/solo_driver/Neverworld_surface_forcing.F90 index a53eaec27e..ab4d9422c1 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverworld_surface_forcing.F90 @@ -1,5 +1,5 @@ -!> Wind and buoyancy forcing for the Neverland configurations -module Neverland_surface_forcing +!> Wind and buoyancy forcing for the Neverworld configurations +module Neverworld_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. @@ -18,16 +18,16 @@ module Neverland_surface_forcing implicit none ; private -public Neverland_wind_forcing -public Neverland_buoyancy_forcing -public Neverland_surface_forcing_init +public Neverworld_wind_forcing +public Neverworld_buoyancy_forcing +public Neverworld_surface_forcing_init !> This control structure should be used to store any run-time variables -!! associated with the Neverland forcing. +!! associated with the Neverworld forcing. !! !! It can be readily modified for a specific case, and because it is private there !! will be no changes needed in other code (although they will have to be recompiled). -type, public :: Neverland_surface_forcing_CS ; private +type, public :: Neverworld_surface_forcing_CS ; private logical :: use_temperature !< If true, use temperature and salinity. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. @@ -39,21 +39,21 @@ module Neverland_surface_forcing character(len=200) :: inputdir !< The directory where NetCDF input files are. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - logical :: first_call = .true. !< True until Neverland_buoyancy_forcing has been called -end type Neverland_surface_forcing_CS + logical :: first_call = .true. !< True until Neverworld_buoyancy_forcing has been called +end type Neverworld_surface_forcing_CS contains !> Sets the surface wind stresses, forces%taux and forces%tauy for the -!! Neverland forcing configuration. -subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) +!! Neverworld forcing configuration. +subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(time_type), intent(in) :: day !< Time used for determining the fluxes. type(ocean_grid_type), intent(inout) :: G !< Grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. + type(Neverworld_surface_forcing_CS), pointer :: CS !< Control structure for this module. ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -110,7 +110,7 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) ! (US%L_to_Z / CS%Rho0) ) ! enddo ; enddo ; endif -end subroutine Neverland_wind_forcing +end subroutine Neverworld_wind_forcing !> Returns the value of a cosine-bell function evaluated at x/L real function cosbell(x,L) @@ -135,8 +135,8 @@ real function spike(x,L) end function spike -!> Surface fluxes of buoyancy for the Neverland configurations. -subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) +!> Surface fluxes of buoyancy for the Neverworld configurations. +subroutine Neverworld_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 !< Forcing fields. @@ -144,7 +144,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real, intent(in) :: dt !< Forcing time step (s). type(ocean_grid_type), intent(inout) :: G !< Grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. + type(Neverworld_surface_forcing_CS), pointer :: CS !< Control structure for this module. ! 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]. @@ -161,7 +161,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call MOM_error(FATAL, "Neverland_buoyancy_forcing: " // & + call MOM_error(FATAL, "Neverworld_buoyancy_forcing: " // & "Temperature and salinity mode not coded!" ) else ! This is the buoyancy only mode. @@ -177,7 +177,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) endif if ( CS%use_temperature ) then - call MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & + call MOM_error(FATAL, "Neverworld_buoyancy_surface_forcing: " // & "Temperature/salinity restoring not coded!" ) else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie @@ -189,7 +189,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & + call MOM_error(FATAL, "Neverworld_buoyancy_surface_forcing: " // & "Temperature/salinity restoring not coded!" ) else ! When modifying the code, comment out this error message. It is here @@ -208,25 +208,25 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) endif endif ! end RESTOREBUOY -end subroutine Neverland_buoyancy_forcing +end subroutine Neverworld_buoyancy_forcing -!> Initializes the Neverland control structure. -subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) +!> Initializes the Neverworld control structure. +subroutine Neverworld_surface_forcing_init(Time, G, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for !! model parameter values. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(Neverland_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure + type(Neverworld_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure !! for this module ! This include declares and sets the variable "version". #include "version_variable.h" ! Local variables - character(len=40) :: mdl = "Neverland_surface_forcing" ! This module's name. + character(len=40) :: mdl = "Neverworld_surface_forcing" ! This module's name. if (associated(CS)) then - call MOM_error(WARNING, "Neverland_surface_forcing_init called with an associated "// & + call MOM_error(WARNING, "Neverworld_surface_forcing_init called with an associated "// & "control structure.") return endif @@ -267,6 +267,6 @@ subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) CS%flux_const = CS%flux_const / 86400.0 endif -end subroutine Neverland_surface_forcing_init +end subroutine Neverworld_surface_forcing_init -end module Neverland_surface_forcing +end module Neverworld_surface_forcing diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 0ddca45c51..f4f8c4698b 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -31,7 +31,7 @@ module MOM_fixed_initialization use DOME_initialization, only : DOME_initialize_topography use ISOMIP_initialization, only : ISOMIP_initialize_topography use benchmark_initialization, only : benchmark_initialize_topography -use Neverland_initialization, only : Neverland_initialize_topography +use Neverworld_initialization, only : Neverworld_initialize_topography use DOME2d_initialization, only : DOME2d_initialize_topography use Kelvin_initialization, only : Kelvin_initialize_topography use sloshing_initialization, only : sloshing_initialize_topography @@ -202,7 +202,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) " \t halfpipe - a zonally uniform channel with a half-sine \n"//& " \t\t profile in the meridional direction. \n"//& " \t benchmark - use the benchmark test case topography. \n"//& - " \t Neverland - use the Neverland test case topography. \n"//& + " \t Neverworld - use the Neverworld test case topography. \n"//& " \t DOME - use a slope and channel configuration for the \n"//& " \t\t DOME sill-overflow test case. \n"//& " \t ISOMIP - use a slope and channel configuration for the \n"//& @@ -227,7 +227,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth, US) case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) - case ("Neverland"); call Neverland_initialize_topography(D, G, PF, max_depth) + case ("Neverword","Neverland"); call Neverworld_initialize_topography(D, G, PF, max_depth) case ("DOME2D"); call DOME2d_initialize_topography(D, G, PF, max_depth) case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth, US) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 07d928d76b..b032cd5c85 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -57,7 +57,7 @@ module MOM_state_initialization use baroclinic_zone_initialization, only : baroclinic_zone_init_temperature_salinity use benchmark_initialization, only : benchmark_initialize_thickness use benchmark_initialization, only : benchmark_init_temperature_salinity -use Neverland_initialization, only : Neverland_initialize_thickness +use Neverworld_initialization, only : Neverworld_initialize_thickness use circle_obcs_initialization, only : circle_obcs_initialize_thickness use lock_exchange_initialization, only : lock_exchange_initialize_thickness use external_gwave_initialization, only : external_gwave_initialize_thickness @@ -257,7 +257,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t ISOMIP - use a configuration for the \n"//& " \t\t ISOMIP test case. \n"//& " \t benchmark - use the benchmark test case thicknesses. \n"//& - " \t Neverland - use the Neverland test case thicknesses. \n"//& + " \t Neverworld - use the Neverworld test case thicknesses. \n"//& " \t search - search a density profile for the interface \n"//& " \t\t densities. This is not yet implemented. \n"//& " \t circle_obcs - the circle_obcs test case is used. \n"//& @@ -292,7 +292,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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) - case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, US, PF, & + case ("Neverwoorld","Neverland"); call Neverworld_initialize_thickness(h, G, GV, US, PF, & 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, & diff --git a/src/user/Neverland_initialization.F90 b/src/user/Neverworld_initialization.F90 similarity index 89% rename from src/user/Neverland_initialization.F90 rename to src/user/Neverworld_initialization.F90 index 64afe85ab5..b31520549b 100644 --- a/src/user/Neverland_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -1,5 +1,5 @@ -!> Initialization for the "Neverland" configuration -module Neverland_initialization +!> Initialization for the "Neverworld" configuration +module Neverworld_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,8 +21,8 @@ module Neverland_initialization #include -public Neverland_initialize_topography -public Neverland_initialize_thickness +public Neverworld_initialize_topography +public Neverworld_initialize_thickness ! 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 @@ -31,8 +31,8 @@ module Neverland_initialization contains -!> This subroutine sets up the Neverland test case topography. -subroutine Neverland_initialize_topography(D, G, param_file, max_depth) +!> This subroutine sets up the Neverworld test case topography. +subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: D !< Ocean bottom depth in the units of depth_max @@ -46,13 +46,13 @@ subroutine Neverland_initialize_topography(D, G, param_file, max_depth) real :: x, y ! This include declares and sets the variable "version". # include "version_variable.h" - character(len=40) :: mdl = "Neverland_initialize_topography" ! This subroutine's name. + character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed real :: nl_roughness_amp, nl_top_amp is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call MOM_mesg(" Neverland_initialization.F90, Neverland_initialize_topography: setting topography", 5) + call MOM_mesg(" Neverworld_initialization.F90, Neverworld_initialize_topography: setting topography", 5) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NL_ROUGHNESS_AMP", nl_roughness_amp, & @@ -82,7 +82,7 @@ subroutine Neverland_initialize_topography(D, G, param_file, max_depth) D(i,j) = D(i,j) * max_depth enddo ; enddo -end subroutine Neverland_initialize_topography +end subroutine Neverworld_initialize_topography ! ----------------------------------------------------------------------------- !> Returns the value of a cosine-bell function evaluated at x/L @@ -106,11 +106,11 @@ real function spike(x, L) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) end function spike -!> This subroutine initializes layer thicknesses for the Neverland test case, +!> This subroutine initializes layer thicknesses for the Neverworld test case, !! by finding the depths of interfaces in a specified latitude-dependent !! temperature profile with an exponentially decaying thermocline on top of a !! linear stratification. -subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, P_ref) +subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, P_ref) 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 @@ -133,12 +133,12 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state real :: h_noise ! Amplitude of noise to scale h by real :: noise ! Noise type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization - character(len=40) :: mdl = "Neverland_initialize_thickness" ! This subroutine's name. + character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - call MOM_mesg(" Neverland_initialization.F90, Neverland_initialize_thickness: setting thickness", 5) + call MOM_mesg(" Neverworld_initialization.F90, Neverworld_initialize_thickness: setting thickness", 5) call get_param(param_file, mdl, "INIT_THICKNESS_PROFILE", h_profile, & "Profile of initial layer thicknesses.", units="m", scale=US%m_to_Z, & fail_if_missing=.true.) @@ -177,6 +177,6 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state h(i,j,1) = max( GV%Angstrom_H, h(i,j,1) ) ! Limit to non-negative enddo ; enddo -end subroutine Neverland_initialize_thickness +end subroutine Neverworld_initialize_thickness -end module Neverland_initialization +end module Neverworld_initialization From 1e0a5e4a7d612ac8f4583d27be22c6102057b044 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 2 Jun 2020 12:17:23 -0800 Subject: [PATCH 025/256] Fix to out-of-bounds error - was operating on segments not on core, oh no. --- 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 69a0adbf25..58e3fb63fc 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4790,7 +4790,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif ; enddo enddo - else + elseif (segment%is_N_or_S) then J = segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied ! jshift+J corresponds to the nearest interior tracer cell index From 4d4dc2fc3bbd2f7bcda4b74420583ab6ed792a6f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 01:12:47 +0000 Subject: [PATCH 026/256] Removes Neverworld_surface_forcing module - The single subroutine that defined the wind stresses for Neverworld (renamed from Neverland) has been moved into MOM_surface_forcing.F90 since an entire module for a single function that had no runtime parameters was overkill. # Conflicts: # src/initialization/MOM_fixed_initialization.F90 --- .../solo_driver/MOM_surface_forcing.F90 | 74 ++++- .../Neverworld_surface_forcing.F90 | 272 ------------------ 2 files changed, 66 insertions(+), 280 deletions(-) delete mode 100644 config_src/solo_driver/Neverworld_surface_forcing.F90 diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 152cfb4b85..834d4b57fb 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -39,8 +39,6 @@ module MOM_surface_forcing use MOM_variables, only : surface use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS -use Neverworld_surface_forcing, only : Neverworld_wind_forcing, Neverworld_buoyancy_forcing -use Neverworld_surface_forcing, only : Neverworld_surface_forcing_init, Neverworld_surface_forcing_CS use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init @@ -204,7 +202,6 @@ module MOM_surface_forcing type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - type(Neverworld_surface_forcing_CS), pointer :: Neverworld_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() !>@} @@ -281,7 +278,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%wind_config) == "const") then call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then - call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverworld_forcing_CSp) + call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -314,8 +311,6 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "Neverworld" .or. trim(CS%buoy_config) == "Neverland") then - call Neverworld_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverworld_forcing_CSp) elseif (trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%buoy_config) == "USER") then @@ -526,6 +521,71 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) call callTree_leave("wind_forcing_gyres") end subroutine wind_forcing_gyres +!> Sets the surface wind stresses, forces%taux and forces%tauy for the +!! Neverworld forcing configuration. +subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< 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 + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: PI, I_rho, y + real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: off + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true.) + + ! Set the surface wind stresses, in units of Pa. A positive taux + ! accelerates the ocean to the (pseudo-)east. + + ! The i-loop extends to is-1 so that taux can be used later in the + ! calculation of ustar - otherwise the lower bound would be Isq. + PI = 4.0*atan(1.0) + forces%taux(:,:) = 0.0 + tau_max = 0.2 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + off = 0.02 + do j=js,je ; do I=is-1,Ieq + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat + + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + endif + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + endif + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + endif + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=js-1,Jeq ; do i=is,ie + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of m s-1. ustar is always positive. + if (associated(forces%ustar)) then + I_rho = US%L_to_Z / CS%Rho0 + do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( (CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + enddo ; enddo + endif + +end subroutine Neverworld_wind_forcing ! Sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) @@ -1756,8 +1816,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, US, param_file, diag, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then - call Neverworld_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverworld_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr" .or.& trim(CS%wind_config) == "SCM_ideal_hurr") then call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) diff --git a/config_src/solo_driver/Neverworld_surface_forcing.F90 b/config_src/solo_driver/Neverworld_surface_forcing.F90 deleted file mode 100644 index ab4d9422c1..0000000000 --- a/config_src/solo_driver/Neverworld_surface_forcing.F90 +++ /dev/null @@ -1,272 +0,0 @@ -!> Wind and buoyancy forcing for the Neverworld configurations -module Neverworld_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/) -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public Neverworld_wind_forcing -public Neverworld_buoyancy_forcing -public Neverworld_surface_forcing_init - -!> This control structure should be used to store any run-time variables -!! associated with the Neverworld forcing. -!! -!! It can be readily modified for a specific case, and because it is private there -!! will be no changes needed in other code (although they will have to be recompiled). -type, public :: Neverworld_surface_forcing_CS ; private - - logical :: use_temperature !< If true, use temperature and salinity. - 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]. - real :: flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. - real, dimension(:,:), pointer :: & - buoy_restore(:,:) => NULL() !< The pattern to restore buoyancy to. - character(len=200) :: inputdir !< The directory where NetCDF input files are. - type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the - !! timing of diagnostic output. - logical :: first_call = .true. !< True until Neverworld_buoyancy_forcing has been called -end type Neverworld_surface_forcing_CS - -contains - -!> Sets the surface wind stresses, forces%taux and forces%tauy for the -!! Neverworld forcing configuration. -subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverworld_surface_forcing_CS), pointer :: CS !< Control structure for this module. - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: x, y - real :: PI - real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] - real :: off - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true.) - - ! Set the surface wind stresses, in units of Pa. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - off = 0.02 - do j=js,je ; do I=is-1,Ieq -! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon - y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - - if (y <= 0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) - endif - if ((y > 0.29) .and. (y <= (0.8-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) - endif - if ((y > (0.8-off)) .and. (y <= (1-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) - endif - enddo ; enddo - - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity, in units of m s-1. ustar - ! is always positive. -! if (associated(forces%ustar)) then ; 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((CS%gust_const + & -! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & -! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * & -! (US%L_to_Z / CS%Rho0) ) -! enddo ; enddo ; endif - -end subroutine Neverworld_wind_forcing - -!> Returns the value of a cosine-bell function evaluated at x/L -real function cosbell(x,L) - - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) - - PI = 4.0*atan(1.0) - cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) -end function cosbell - -!> Returns the value of a sin-spike function evaluated at x/L -real function spike(x,L) - - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) - - PI = 4.0*atan(1.0) - spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) -end function spike - - -!> Surface fluxes of buoyancy for the Neverworld configurations. -subroutine Neverworld_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 !< Forcing fields. - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< Forcing time step (s). - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverworld_surface_forcing_CS), pointer :: CS !< Control structure for this module. - ! 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 ! Density being restored toward [R ~> kg m-3] - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call MOM_error(FATAL, "Neverworld_buoyancy_forcing: " // & - "Temperature and salinity mode not coded!" ) - else - ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - if (CS%restorebuoy .and. CS%first_call) then - call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) - CS%first_call = .false. - ! Set CS%buoy_restore(i,j) here - endif - - if ( CS%use_temperature ) then - call MOM_error(FATAL, "Neverworld_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call MOM_error(FATAL, "Neverworld_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! The -1 is because density has the opposite sign to buoyancy. - 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 [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 * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine Neverworld_buoyancy_forcing - -!> Initializes the Neverworld control structure. -subroutine Neverworld_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for - !! model parameter values. - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(Neverworld_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - ! This include declares and sets the variable "version". -#include "version_variable.h" - ! Local variables - character(len=40) :: mdl = "Neverworld_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "Neverworld_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "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.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - 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, "GUST_CONST", CS%gust_const, & -! "The background gustiness in the winds.", units="Pa", & -! default=0.02) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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 - endif - -end subroutine Neverworld_surface_forcing_init - -end module Neverworld_surface_forcing From 15c477f80ca718b77743220ef9cfa834d13b4830 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 02:46:47 +0000 Subject: [PATCH 027/256] Add "scurves" wind configuration - Allows a piecewise scurve (cubics with zero gradients at nodes) to be defined to construct a zonal wind stress profile - Enabled with WIND_CONFIG="scurves" - Requires mandatory parameters WIND_SCURVES_LATS and WIND_SCURVES_TAUX that define the nodal positions and values. - Used in Neverworld2 --- .../solo_driver/MOM_surface_forcing.F90 | 80 +++++++++++++++++++ 1 file changed, 80 insertions(+) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 834d4b57fb..1321f004c9 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -109,6 +109,9 @@ module MOM_surface_forcing !! the same between compilers. logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the !! gustless wind friction velocity. + ! if WIND_CONFIG=='scurves' then use the following to define a piecwise scurve profile + real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] + real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [Pa] real :: T_north !< target temperatures at north used in buoyancy_forcing_linear real :: T_south !< target temperatures at south used in buoyancy_forcing_linear @@ -279,6 +282,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS) + elseif (trim(CS%wind_config) == "scurves") then + call scurve_wind_forcing(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -587,6 +592,71 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) end subroutine Neverworld_wind_forcing +!> Sets the zonal wind stresses to a piecewise series of s-curves. +subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< 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 + integer :: i, j, kseg + real :: lon, lat, I_rho, y, L +! real :: ydata(7) = (/ -70., -45., -15., 0., 15., 45., 70. /) +! real :: taudt(7) = (/ 0., 0.2, -0.1, -0.02, -0.1, 0.1, 0. /) + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true.) + + kseg = 1 + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + lon = G%geoLonCu(I,j) + lat = G%geoLatCu(I,j) + + ! Find segment k s.t. ydata(k)<= lat < ydata(k+1) + do while (lat>=CS%scurves_ydata(kseg+1) .and. kseg<6) + kseg = kseg+1 + enddo + do while (lat1) + kseg = kseg-1 + enddo + + y = lat - CS%scurves_ydata(kseg) + L = CS%scurves_ydata(kseg+1) - CS%scurves_ydata(kseg) + forces%taux(I,j) = CS%scurves_taux(kseg) + & + ( CS%scurves_taux(kseg+1) - CS%scurves_taux(kseg) ) * scurve(y, L) + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of m s-1. ustar is always positive. + if (associated(forces%ustar)) then + I_rho = US%L_to_Z / CS%Rho0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = sqrt( (CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + enddo ; enddo + endif + +end subroutine scurve_wind_forcing + +!> Returns the value of a cosine-bell function evaluated at x/L +real function scurve(x,L) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: s + + s = x/L + scurve = (3. - 2.*s) * (s*s) +end function scurve + ! Sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that @@ -1717,6 +1787,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C else CS%answers_2018 = .false. endif + if (trim(CS%wind_config) == "scurves") then + call get_param(param_file, mdl, "WIND_SCURVES_LATS", CS%scurves_ydata, & + "A list of latitudes defining a piecewise scurve profile "//& + "for zonal wind stress.", & + units="degrees N", fail_if_missing=.true.) + call get_param(param_file, mdl, "WIND_SCURVES_TAUX", CS%scurves_taux, & + "A list of zonal wind stress values at latitudes "//& + "WIND_SCURVES_LATS defining a piecewise scurve profile.", & + units="Pa", fail_if_missing=.true.) + endif if ((trim(CS%wind_config) == "2gyre") .or. & (trim(CS%wind_config) == "1gyre") .or. & (trim(CS%wind_config) == "gyres") .or. & From 53a39330fde9c0d92fdce26309456bbc05dbaa5a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 02:51:36 +0000 Subject: [PATCH 028/256] Adds the Neverworld2 topography - This topography is working but still likely to evolve. - The code will be superseded by a more general approach. --- .../MOM_fixed_initialization.F90 | 4 +- src/user/Neverworld_initialization.F90 | 174 +++++++++++++++++- 2 files changed, 176 insertions(+), 2 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f4f8c4698b..6b426edfa1 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -32,6 +32,7 @@ module MOM_fixed_initialization use ISOMIP_initialization, only : ISOMIP_initialize_topography use benchmark_initialization, only : benchmark_initialize_topography use Neverworld_initialization, only : Neverworld_initialize_topography +use Neverworld_initialization, only : Neverworld2_initialize_topography use DOME2d_initialization, only : DOME2d_initialize_topography use Kelvin_initialization, only : Kelvin_initialize_topography use sloshing_initialization, only : sloshing_initialize_topography @@ -227,7 +228,8 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth, US) case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) - case ("Neverword","Neverland"); call Neverworld_initialize_topography(D, G, PF, max_depth) + case ("Neverworld","Neverland"); call Neverworld2_initialize_topography(D, G, PF, max_depth) + case ("Neverworld2"); call Neverworld2_initialize_topography(D, G, PF, max_depth) case ("DOME2D"); call DOME2d_initialize_topography(D, G, PF, max_depth) case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth, US) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index b31520549b..6a981729f0 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -23,6 +23,7 @@ module Neverworld_initialization public Neverworld_initialize_topography public Neverworld_initialize_thickness +public Neverworld2_initialize_topography ! 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 @@ -83,7 +84,6 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) enddo ; enddo end subroutine Neverworld_initialize_topography -! ----------------------------------------------------------------------------- !> Returns the value of a cosine-bell function evaluated at x/L real function cosbell(x, L) @@ -106,6 +106,178 @@ real function spike(x, L) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) end function spike +!> Sets up the Neverworld2 topography. +subroutine Neverworld2_initialize_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in the units of depth_max + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + ! Local variables + real :: lon, lat + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. + integer :: i, j + real, parameter :: sdf = 0.05 ! Shelf depth as fraction of maximum depth + + call MOM_mesg(" Neverworld_initialization.F90, Neverworld2_initialize_topography: setting topography", 5) + call log_version(param_file, mdl, version, "") + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = (G%geoLonT(i,j)-G%west_lon) + lat = G%geoLatT(i,j) + D(i,j) = 1.0 + ! Box Atlantic with re-entrant channel between 60S nad 40S + D(i,j) = min( D(i,j), NS_coast(lon, lat, 0., -40., 90., 5., sdf) ) ! America + D(i,j) = min( D(i,j), NS_coast(lon, lat, G%len_lon, -40., 90., 5., sdf) ) + D(i,j) = min( D(i,j), NS_coast(lon, lat, 0., -90., -60., 5., sdf) ) ! Antarctic Peninsula + D(i,j) = min( D(i,j), NS_coast(lon, lat, G%len_lon, -90., -60., 5., sdf) ) + D(i,j) = min( D(i,j), EW_coast(lon, lat, 0., G%len_lon, G%south_lat, 5., sdf) ) ! Antarctica + D(i,j) = min( D(i,j), EW_coast(lon, lat, 0., G%len_lon, G%south_lat+G%len_lat, 5., sdf) ) ! Greenland "wall" + + ! Ridge around Drake passage + D(i,j) = min( D(i,j), circ_ridge(lon, lat, 0., -50., 10., 2., 0.5) ) + + ! Mid-Atlantic ridge + D(i,j) = min( D(i,j), NS_ridge(lon, lat, 0.5*G%len_lon, -90., 90., 30., 0.5) ) + + ! Dimensionalize by scaling 1 to max_depth + D(i,j) = D(i,j) * max_depth + enddo ; enddo + +end subroutine Neverworld2_initialize_topography + +!> Returns the value of a triangular function centered at x=x0 with value 1 +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! If clip is present the top of the cone is cut off at "clip", which +!! effectively defaults to 1. +real function cone(x, x0, L, clip) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real, optional, intent(in) :: clip !< clipping height of cone [nondim] + + cone = max( 0., 1. - abs(x - x0) / L ) + if (present(clip)) cone = min(clip, cone) +end function cone + +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +real function scurve(x, x0, L) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + scurve = ( 3. - 2.*s ) * ( s * s ) +end function scurve + +!> Returns a "coastal" profile. +real function cstprof(x, x0, L, lf, bf, sf, sh) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: lf !< fraction of width that is "land" [nondim] + real, intent(in) :: bf !< fraction of width that is "beach" [nondim] + real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) +end function cstprof + +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +real function dist_line_fixed_x(x, y, x0, y0, y1) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment [nondim] + real, intent(in) :: y0 !< y-position of line segment end[nondim] + real, intent(in) :: y1 !< y-position of line segment end[nondim] + real :: dx, yr, dy + + dx = x - x0 + yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 + dy = y - yr ! =0 within y0y1 + dist_line_fixed_x = sqrt( dx*dx + dy*dy ) +end function dist_line_fixed_x + +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +real function dist_line_fixed_y(x, y, x0, x1, y0) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment end[nondim] + real, intent(in) :: x1 !< x-position of line segment end[nondim] + real, intent(in) :: y0 !< y-position of line segment [nondim] + real :: dx, yr, dy + + dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) +end function dist_line_fixed_y + +!> A "coast profile" applied in an N-S line from lon0,lat0 to lon0,lat1. +real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast end [degrees_N] + real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] + real, intent(in) :: dlon !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) + NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) +end function NS_coast + +!> A "coast profile" applied in an E-W line from lon0,lat0 to lon1,lat0. +real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast end [degrees_E] + real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast [degrees_N] + real, intent(in) :: dlat !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_y( lon, lat, lon0, lon1, lat0 ) + EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) +end function EW_coast + +!> A NS ridge +real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) + NS_ridge = 1. - rh * cone(r, 0., dlon) +end function NS_ridge + + +!> A circular ridge +real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 +end function circ_ridge + !> This subroutine initializes layer thicknesses for the Neverworld test case, !! by finding the depths of interfaces in a specified latitude-dependent !! temperature profile with an exponentially decaying thermocline on top of a From cf517454e45b29493abba0d4953ddf02655f36d6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 08:31:46 -0400 Subject: [PATCH 029/256] +(*)Fix conflicting defaults for NKML Added the new runtime parameter Z_INIT_SEPARATE_MIXED_LAYER and eliminated the extra get_param calls for NKML and NKBL in MOM_temp_salt_initilaize_from_Z with default values that are inconsistent with the defaults in MOM.F90. Also revised tracer_z_init_array and find_interfaces to eliminate unused arguments and added grid type arguments so that these routines follow the rest of the MOM6 code in how it deals with memory and indexing. There are interface changes, and unless Z_INIT_SEPARATE_MIXED_LAYER is explicitly set to true, some non-ALE cases that explicitly set NKML (and do not just take the default value) will have changed answers. However, a preceeding PR to MOM6-examples will avoid these answer changes and this PR fixes the problem that was in MOM6 with conflicting default values for NKML and NKBL. Reusing MOM_parameter_doc.short for MOM_input will once again give the same answers (perhaps with added layout parameters to set a non-default halo size in memory) in the MOM6-examples test suite. --- .../MOM_state_initialization.F90 | 56 +++---- src/tracer/MOM_tracer_Z_init.F90 | 140 +++++++++--------- 2 files changed, 101 insertions(+), 95 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 07d928d76b..f52e2aca47 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1987,18 +1987,18 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param integer :: isd, ied, jsd, jed ! data domain indices integer :: i, j, k, ks, np, ni, nj - integer :: idbg, jdbg - integer :: nkml, nkbl ! number of mixed and buffer layers + integer :: nkml ! The number of layers in the mixed layer. integer :: kd, inconsistent integer :: nkd ! number of levels to use for regridding input arrays real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. - real :: PI_180 ! for conversion from degrees to radians + real :: PI_180 ! for conversion from degrees to radians real, dimension(:,:), pointer :: shelf_area => NULL() - real :: min_depth ! The minimum depth [Z ~> m]. - real :: dilate + real :: Hmix_default ! The default initial mixed layer depth [m]. + real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. + real :: dilate ! A dilation factor to match topography [nondim] real :: missing_value_temp, missing_value_salt logical :: correct_thickness character(len=40) :: potemp_var, salin_var @@ -2037,6 +2037,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 logical :: use_ice_shelf logical :: pre_gridded + logical :: separate_mixed_layer ! If true, handle the mixed layers differently. character(len=10) :: remappingScheme real :: tempAvg, saltAvg integer :: nPoints, ans @@ -2063,14 +2064,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param eos => tv%eqn_of_state -! 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.) 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) - - call get_param(PF, mdl, "NKML",nkml,default=0) - call get_param(PF, mdl, "NKBL",nkbl,default=0) call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE",filename, & "The name of the z-space input file used to initialize "//& @@ -2153,6 +2148,19 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param "their target densities using mostly temperature "//& "This approach can be problematic, particularly in the "//& "high latitudes.", default=.true., do_not_log=just_read) + call get_param(PF, mdl, "Z_INIT_SEPARATE_MIXED_LAYER", separate_mixed_layer, & + "If true, distribute the topmost Z_INIT_HMIX_DEPTH of water over NKML layers, "//& + "and do not correct the density of the topmost NKML+NKBL layers. Otherwise "//& + "all layers are initialized based on the depths of their target densities.", & + default=.false., do_not_log=just_read.or.(GV%nkml==0)) + if (GV%nkml == 0) separate_mixed_layer = .false. + call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, default=0.0) + call get_param(PF, mdl, "Z_INIT_HMIX_DEPTH", Hmix_depth, & + "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& + "is set to true.", default=Hmix_default, units="m", scale=US%m_to_Z, & + do_not_log=(just_read .or. .not.separate_mixed_layer)) + ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but + ! it reproduces previous answers. endif if (just_read) then call cpu_clock_end(id_clock_routine) @@ -2232,11 +2240,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (useALEremapping) then call cpu_clock_begin(id_clock_ALE) nkd = max(GV%ke, kd) - ! The regridding tools (grid generation) are coded to work on model arrays of the same - ! vertical shape. We need to re-write the regridding if the model has fewer layers - ! than the data. -AJA -! if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& -! "Data has more levels than the model - this has not been coded yet!") + ! Build the source grid and copy data onto model-shaped arrays with vanished layers allocate( tmp_mask_in(isd:ied,jsd:jed,nkd) ) ; tmp_mask_in(:,:,:) = 0. allocate( h1(isd:ied,jsd:jed,nkd) ) ; h1(:,:,:) = 0. @@ -2335,8 +2339,10 @@ 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) + nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml + 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) + nlevs, nkml, hml=Hmix_depth, eps_z=eps_z, eps_rho=eps_rho) if (correct_thickness) then call adjustEtaToFitBathymetry(G, GV, US, zi, h) @@ -2363,12 +2369,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif endif - 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,:)) + call tracer_z_init_array(temp_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%T) + call tracer_z_init_array(salt_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%S) do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. @@ -2402,12 +2404,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif enddo ; enddo ; enddo - ! Finally adjust to target density - ks = max(0,nkml)+max(0,nkbl)+1 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) + ! Finally adjust to target density + ks = 1 ; if (separate_mixed_layer) ks = GV%nk_rho_varies + 1 + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), tv%P_Ref, niter, & + missing_value, h, ks, G, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index a84814d40a..401bf82a2b 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -7,7 +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_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain use MOM_unit_scaling, only : unit_scale_type use netcdf @@ -275,51 +275,49 @@ 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 +!> 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 +subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, nlevs, & + eps_z, tr) + 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) :: tr_in !< The z-space array of tracer concentrations that is read in. + real, dimension(nk_data+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 + integer, intent(in) :: nlay !< The number of vertical layers in the target grid + real, dimension(SZI_(G),SZJ_(G),nlay+1), & + intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] + real, intent(in) :: land_fill !< fill in data over land (1) + integer, dimension(SZI_(G),SZJ_(G)), & + 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(SZI_(G),SZJ_(G),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, dimension(nk_data) :: tr_1d !< a copy of the input tracer concentrations in a column. + real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. + real, dimension(nlay) :: tr_ ! A 1-d column of output tracer concentrations + integer :: k_top, k_bot, k_bot_prev, kstart real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. - real, dimension(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 + real, dimension(nk_data) :: wt !< The fractional weight for each layer in the range between z1 and z2 + real, dimension(nk_data) :: 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. + integer :: i, j, k, kz, is, ie, js, je - nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - do j=1,ny - i_loop: do i=1,nx - if (nlevs(i,j) == 0 .or. wet(i,j) == 0.) then + do j=js,je + i_loop: do i=is,ie + if (nlevs(i,j) == 0 .or. G%mask2dT(i,j) == 0.) then tr(i,j,:) = land_fill cycle i_loop endif - do k=1,nz + do k=1,nk_data tr_1d(k) = tr_in(i,j,k) enddo @@ -334,11 +332,11 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl tr(i,j,k) = tr_1d(nlevs(i,j)) else - kstart=k_bot + 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 + 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 @@ -362,8 +360,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl 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))) + 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 @@ -373,7 +370,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl 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) + if (e_1d(k)-e_1d(k+1) <= eps_z) tr(i,j,k) = tr(i,j,k-1) enddo enddo i_loop @@ -612,9 +609,10 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope !> Find interface positions corresponding to density profile -subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) +subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, 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 + 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]. @@ -627,8 +625,8 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, 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 + integer, optional, intent(in) :: nkml !< number of mixed layer pieces to distribute over + !! a depth of hml. 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]. @@ -638,14 +636,16 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, logical :: unstable integer :: dir integer, dimension(SZI_(G),SZK_(G)+1) :: ki_ - real, dimension(SZI_(G),SZK_(G)+1) :: zi_ + real, dimension(SZI_(G),SZK_(G)+1) :: zi_ ! A slice of interface heights (negative downward) [Z ~> m]. integer, dimension(SZI_(G),SZJ_(G)) :: nlevs_data integer, dimension(SZI_(G)) :: lo, hi - real :: slope,rsm,drhodz,hml_ + real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] + real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] + real :: hml_ ! The depth of the mixed layer to use for the topmost nkml_ layers [Z ~> m]. 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 :: epsln_rho ! A negligibly small density change [R ~> kg m-3]. real, parameter :: zoff=0.999 - integer :: kk,nkml_,nkbl_ + integer :: nkml_ logical :: debug_ = .false. integer :: i, j, k, m, n, is, ie, js, je, nz @@ -658,7 +658,6 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, 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*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 @@ -740,15 +739,19 @@ 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_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_tgt !< desired potential density [R ~> kg m-3]. +subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, G, US, eos, h_massless) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: temp !< potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: salt !< salinity [PSU] + real, dimension(SZK_(G)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. 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 - real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 @@ -757,14 +760,13 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real, parameter :: T_max = 31.0, T_min = -2.0 ! Local variables (All of which need documentation!) - real, dimension(size(temp,1),size(temp,3)) :: & + real, dimension(SZI_(G),SZK_(G)) :: & 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 ! Reference pressures [R L2 T-2 ~> Pa] - integer :: nx, ny, nz, nt, i, j, k, n, itt + real, dimension(SZI_(G)) :: press ! Reference pressures [R L2 T-2 ~> Pa] 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 @@ -775,6 +777,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, 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 + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, kz, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! These hard coded parameters need to be set properly. S_min = 0.5 ; S_max = 65.0 @@ -788,11 +794,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, ! 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 + EOSdom(:) = EOS_domain(G%HI) - do j=1,ny + do j=js,je dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) @@ -800,13 +805,12 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, 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), eos, (/1,nx/) ) + do k=1,nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & - eos, (/1,nx/) ) + eos, EOSdom ) enddo - do k=k_start,nz ; do i=1,nx - + do k=k_start,nz ; do i=is,ie ! 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 @@ -824,18 +828,18 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, endif enddo ; enddo if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop + 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), eos, (/1,nx/) ) + do k=1,nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & - eos, (/1,nx/) ) + eos, EOSdom ) enddo - do k=k_start,nz ; do i=1,nx + do k=k_start,nz ; do i=is,ie ! 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) From b9e44acf964b9ab634fb400ac624ca691995feb2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 19:15:09 +0000 Subject: [PATCH 030/256] Adds "basin builder" module - Allows run-time construction of topography defined by a list of functions with parameters, e.g. ``` BBUILDER_007_FUNC = "circ_conic_ridge" ! ! The basin builder function to apply with parameters BBUILDER_007_PARS. Choices ! are: NS_COAST, EW_COAST, CIRC_CONIC_RIDGE, NS_CONIC_RIDGE. BBUILDER_007_PARS = 0.0, -50.0, 10.0, 2.0, 200. ! [degrees_E,degrees_N,degrees,degrees,m] ! CIRC_CONIC_RIDGE parameters: center longitude, center latitude, ring radius, ! footprint radius, ridge height. ``` --- .../MOM_fixed_initialization.F90 | 3 + src/user/basin_builder.F90 | 248 ++++++++++++++++++ 2 files changed, 251 insertions(+) create mode 100644 src/user/basin_builder.F90 diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 6b426edfa1..4523d86e00 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -30,6 +30,7 @@ module MOM_fixed_initialization use user_initialization, only : user_initialize_topography use DOME_initialization, only : DOME_initialize_topography use ISOMIP_initialization, only : ISOMIP_initialize_topography +use basin_builder, only : basin_builder_topography use benchmark_initialization, only : benchmark_initialize_topography use Neverworld_initialization, only : Neverworld_initialize_topography use Neverworld_initialization, only : Neverworld2_initialize_topography @@ -202,6 +203,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) " \t\t wall at the southern face. \n"//& " \t halfpipe - a zonally uniform channel with a half-sine \n"//& " \t\t profile in the meridional direction. \n"//& + " \t bbuilder - build topography from list of functions. \n"//& " \t benchmark - use the benchmark test case topography. \n"//& " \t Neverworld - use the Neverworld test case topography. \n"//& " \t DOME - use a slope and channel configuration for the \n"//& @@ -227,6 +229,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) case ("halfpipe"); call initialize_topography_named(D, G, PF, config, max_depth, US) case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth, US) case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) + case ("bbuilder"); call basin_builder_topography(D, G, PF, max_depth) case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) case ("Neverworld","Neverland"); call Neverworld2_initialize_topography(D, G, PF, max_depth) case ("Neverworld2"); call Neverworld2_initialize_topography(D, G, PF, max_depth) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 new file mode 100644 index 0000000000..64b5536827 --- /dev/null +++ b/src/user/basin_builder.F90 @@ -0,0 +1,248 @@ +!> An idealized topography building system +module basin_builder + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_string_functions, only : lowercase +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +#include + +public basin_builder_topography + +! This include declares and sets the variable "version". +# include "version_variable.h" +character(len=40) :: mdl = "basin_builder" ! This module's name. + +contains + +!> Constructs idealized topography from simple functions +subroutine basin_builder_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in the units of depth_max + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + ! Local variables + character(len=17) :: pname1, pname2 ! For construction of parameter names + character(len=20) :: funcs ! Basin build function + real, dimension(20) :: pars ! Parameters for each function + real :: lon ! Longitude [degrees_E} + real :: lat ! Latitude [degrees_N] + real :: dfrac ! Fraction of depth [nondim] + integer :: i, j, n, n_funcs + + call MOM_mesg(" basin_builder.F90, basin_builder_topography: setting topography", 5) + call log_version(param_file, mdl, version, "") + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + D(i,j) = 1.0 + enddo ; enddo + + call get_param(param_file, mdl, "BBUILDER_N", n_funcs, & + "Number of pieces of topography to use.", fail_if_missing=.true.) + + do n=1,n_funcs + write( pname1, "('BBUILDER_',i3.3,'_FUNC')" ) n + write( pname2, "('BBUILDER_',i3.3,'_PARS')" ) n + call get_param(param_file, mdl, pname1, funcs, & + "The basin builder function to apply with parameters "//& + trim(pname2)//". Choices are: NS_COAST, EW_COAST, "//& + "CIRC_CONIC_RIDGE, NS_CONIC_RIDGE.", & + fail_if_missing=.true.) + pars(:) = 0. + if (trim(lowercase(funcs)) == 'ns_coast') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_COAST parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, shelf depth.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_coast(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ns_conic_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_CONIC_RIDGE parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ew_coast') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "EW_COAST parameters: latitude, starting longitude, "//& + "ending longitude, footprint radius, shelf depth.", & + units="degrees_N,degrees_E,degrees_E,degrees,m", & + fail_if_missing=.true.) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), EW_coast(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + elseif (trim(lowercase(funcs)) == 'circ_conic_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "CIRC_CONIC_RIDGE parameters: center longitude, center latitude, "//& + "ring radius, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees,degrees,m", & + fail_if_missing=.true.) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), circ_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo + else + call MOM_error(FATAL, "basin_builder.F90, basin_builer_topography:\n"//& + "Unrecognized function "//trim(funcs)) + endif + + enddo ! n + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Dimensionalize by scaling 1 to max_depth + D(i,j) = D(i,j) * max_depth + enddo ; enddo + +end subroutine basin_builder_topography + +!> Returns the value of a triangular function centered at x=x0 with value 1 +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! If clip is present the top of the cone is cut off at "clip", which +!! effectively defaults to 1. +real function cone(x, x0, L, clip) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real, optional, intent(in) :: clip !< clipping height of cone [nondim] + + cone = max( 0., 1. - abs(x - x0) / L ) + if (present(clip)) cone = min(clip, cone) +end function cone + +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +real function scurve(x, x0, L) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< half-width of base of cone [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + scurve = ( 3. - 2.*s ) * ( s * s ) +end function scurve + +!> Returns a "coastal" profile. +real function cstprof(x, x0, L, lf, bf, sf, sh) + real, intent(in) :: x !< non-dimensional coordinate [nondim] + real, intent(in) :: x0 !< position of peak [nondim] + real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: lf !< fraction of width that is "land" [nondim] + real, intent(in) :: bf !< fraction of width that is "beach" [nondim] + real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: s + + s = max( 0., min( 1.,( x - x0 ) / L ) ) + cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) +end function cstprof + +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +real function dist_line_fixed_x(x, y, x0, y0, y1) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment [nondim] + real, intent(in) :: y0 !< y-position of line segment end[nondim] + real, intent(in) :: y1 !< y-position of line segment end[nondim] + real :: dx, yr, dy + + dx = x - x0 + yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 + dy = y - yr ! =0 within y0y1 + dist_line_fixed_x = sqrt( dx*dx + dy*dy ) +end function dist_line_fixed_x + +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +real function dist_line_fixed_y(x, y, x0, x1, y0) + real, intent(in) :: x !< non-dimensional x-coordinate [nondim] + real, intent(in) :: y !< non-dimensional y-coordinate [nondim] + real, intent(in) :: x0 !< x-position of line segment end[nondim] + real, intent(in) :: x1 !< x-position of line segment end[nondim] + real, intent(in) :: y0 !< y-position of line segment [nondim] + real :: dx, yr, dy + + dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) +end function dist_line_fixed_y + +!> A "coast profile" applied in an N-S line from lonC,lat0 to lonC,lat1. +real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of coast [degrees_E] + real, intent(in) :: lat0 !< Latitude of coast end [degrees_N] + real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] + real, intent(in) :: dlon !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) +end function NS_coast + +!> A "coast profile" applied in an E-W line from lon0,latC to lon1,latC. +real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: latC !< Latitude of coast [degrees_N] + real, intent(in) :: lon0 !< Longitude of coast end [degrees_E] + real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] + real, intent(in) :: dlat !< "Radius" of coast profile [degrees] + real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_y( lon, lat, lon0, lon1, latC ) + EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) +end function EW_coast + +!> A NS ridge +real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_conic_ridge = 1. - rh * cone(r, 0., dlon) +end function NS_conic_ridge + +!> A circular ridge +real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_conic_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 +end function circ_conic_ridge + +end module basin_builder From 69d155c7d998d65da72949bb5997750d52a582a6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 19:24:24 +0000 Subject: [PATCH 031/256] Remove Neverworld2 subroutine after adding "basin builder" - The hard-coded implementation of the Neverworld2 topography has been replaced by the basin_builder approach so I'm deleting to avoid more unused code. This was added on the branch so the this minimizes net changes from dev/gfdl. --- .../MOM_fixed_initialization.F90 | 4 +- src/user/Neverworld_initialization.F90 | 43 ------------------- 2 files changed, 1 insertion(+), 46 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 4523d86e00..1ddf6f2345 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -33,7 +33,6 @@ module MOM_fixed_initialization use basin_builder, only : basin_builder_topography use benchmark_initialization, only : benchmark_initialize_topography use Neverworld_initialization, only : Neverworld_initialize_topography -use Neverworld_initialization, only : Neverworld2_initialize_topography use DOME2d_initialization, only : DOME2d_initialize_topography use Kelvin_initialization, only : Kelvin_initialize_topography use sloshing_initialization, only : sloshing_initialize_topography @@ -231,8 +230,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) case ("bbuilder"); call basin_builder_topography(D, G, PF, max_depth) case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) - case ("Neverworld","Neverland"); call Neverworld2_initialize_topography(D, G, PF, max_depth) - case ("Neverworld2"); call Neverworld2_initialize_topography(D, G, PF, max_depth) + case ("Neverworld","Neverland"); call Neverworld_initialize_topography(D, G, PF, max_depth) case ("DOME2D"); call DOME2d_initialize_topography(D, G, PF, max_depth) case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth, US) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 6a981729f0..5a21966c9d 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -23,7 +23,6 @@ module Neverworld_initialization public Neverworld_initialize_topography public Neverworld_initialize_thickness -public Neverworld2_initialize_topography ! 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 @@ -106,48 +105,6 @@ real function spike(x, L) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) end function spike -!> Sets up the Neverworld2 topography. -subroutine Neverworld2_initialize_topography(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units - ! Local variables - real :: lon, lat - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. - integer :: i, j - real, parameter :: sdf = 0.05 ! Shelf depth as fraction of maximum depth - - call MOM_mesg(" Neverworld_initialization.F90, Neverworld2_initialize_topography: setting topography", 5) - call log_version(param_file, mdl, version, "") - - do j=G%jsc,G%jec ; do i=G%isc,G%iec - lon = (G%geoLonT(i,j)-G%west_lon) - lat = G%geoLatT(i,j) - D(i,j) = 1.0 - ! Box Atlantic with re-entrant channel between 60S nad 40S - D(i,j) = min( D(i,j), NS_coast(lon, lat, 0., -40., 90., 5., sdf) ) ! America - D(i,j) = min( D(i,j), NS_coast(lon, lat, G%len_lon, -40., 90., 5., sdf) ) - D(i,j) = min( D(i,j), NS_coast(lon, lat, 0., -90., -60., 5., sdf) ) ! Antarctic Peninsula - D(i,j) = min( D(i,j), NS_coast(lon, lat, G%len_lon, -90., -60., 5., sdf) ) - D(i,j) = min( D(i,j), EW_coast(lon, lat, 0., G%len_lon, G%south_lat, 5., sdf) ) ! Antarctica - D(i,j) = min( D(i,j), EW_coast(lon, lat, 0., G%len_lon, G%south_lat+G%len_lat, 5., sdf) ) ! Greenland "wall" - - ! Ridge around Drake passage - D(i,j) = min( D(i,j), circ_ridge(lon, lat, 0., -50., 10., 2., 0.5) ) - - ! Mid-Atlantic ridge - D(i,j) = min( D(i,j), NS_ridge(lon, lat, 0.5*G%len_lon, -90., 90., 30., 0.5) ) - - ! Dimensionalize by scaling 1 to max_depth - D(i,j) = D(i,j) * max_depth - enddo ; enddo - -end subroutine Neverworld2_initialize_topography - !> Returns the value of a triangular function centered at x=x0 with value 1 !! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. !! If clip is present the top of the cone is cut off at "clip", which From df53cae927b79a3adb04094299dfb1daa81c166d Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 21:47:55 +0000 Subject: [PATCH 032/256] Adds scurve version of N-S ridge and circular ridge to basin_builder - CPT discussion suggest a smoother profile for the mid-atlantic ridge which I've implemented as an scurve. --- src/user/basin_builder.F90 | 69 +++++++++++++++++++++++++++++++++++--- 1 file changed, 65 insertions(+), 4 deletions(-) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index 64b5536827..2dccc0d5eb 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -36,7 +36,6 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) real, dimension(20) :: pars ! Parameters for each function real :: lon ! Longitude [degrees_E} real :: lat ! Latitude [degrees_N] - real :: dfrac ! Fraction of depth [nondim] integer :: i, j, n, n_funcs call MOM_mesg(" basin_builder.F90, basin_builder_topography: setting topography", 5) @@ -55,7 +54,8 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) call get_param(param_file, mdl, pname1, funcs, & "The basin builder function to apply with parameters "//& trim(pname2)//". Choices are: NS_COAST, EW_COAST, "//& - "CIRC_CONIC_RIDGE, NS_CONIC_RIDGE.", & + "CIRC_CONIC_RIDGE, NS_CONIC_RIDGE, CIRC_SCURVE_RIDGE, "//& + "NS_SCURVE_RIDGE.", & fail_if_missing=.true.) pars(:) = 0. if (trim(lowercase(funcs)) == 'ns_coast') then @@ -64,6 +64,7 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) "ending latitude, footprint radius, shelf depth.", & units="degrees_E,degrees_N,degrees_N,degrees,m", & fail_if_missing=.true.) + pars(5) = pars(5) / max_depth do j=G%jsc,G%jec ; do i=G%isc,G%iec lon = G%geoLonT(i,j) lat = G%geoLatT(i,j) @@ -75,17 +76,31 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) "ending latitude, footprint radius, ridge height.", & units="degrees_E,degrees_N,degrees_N,degrees,m", & fail_if_missing=.true.) + pars(5) = pars(5) / max_depth do j=G%jsc,G%jec ; do i=G%isc,G%iec lon = G%geoLonT(i,j) lat = G%geoLatT(i,j) D(i,j) = min( D(i,j), NS_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) enddo ; enddo + elseif (trim(lowercase(funcs)) == 'ns_scurve_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "NS_SCURVE_RIDGE parameters: longitude, starting latitude, "//& + "ending latitude, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees_N,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), NS_scurve_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo elseif (trim(lowercase(funcs)) == 'ew_coast') then call get_param(param_file, mdl, pname2, pars(1:5), & "EW_COAST parameters: latitude, starting longitude, "//& "ending longitude, footprint radius, shelf depth.", & units="degrees_N,degrees_E,degrees_E,degrees,m", & fail_if_missing=.true.) + pars(5) = pars(5) / max_depth do j=G%jsc,G%jec ; do i=G%isc,G%iec lon = G%geoLonT(i,j) lat = G%geoLatT(i,j) @@ -97,11 +112,24 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) "ring radius, footprint radius, ridge height.", & units="degrees_E,degrees_N,degrees,degrees,m", & fail_if_missing=.true.) + pars(5) = pars(5) / max_depth do j=G%jsc,G%jec ; do i=G%isc,G%iec lon = G%geoLonT(i,j) lat = G%geoLatT(i,j) D(i,j) = min( D(i,j), circ_conic_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) enddo ; enddo + elseif (trim(lowercase(funcs)) == 'circ_scurve_ridge') then + call get_param(param_file, mdl, pname2, pars(1:5), & + "CIRC_SCURVe_RIDGE parameters: center longitude, center latitude, "//& + "ring radius, footprint radius, ridge height.", & + units="degrees_E,degrees_N,degrees,degrees,m", & + fail_if_missing=.true.) + pars(5) = pars(5) / max_depth + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon = G%geoLonT(i,j) + lat = G%geoLatT(i,j) + D(i,j) = min( D(i,j), circ_scurve_ridge(lon, lat, pars(1), pars(2), pars(3), pars(4), pars(5)) ) + enddo ; enddo else call MOM_error(FATAL, "basin_builder.F90, basin_builer_topography:\n"//& "Unrecognized function "//trim(funcs)) @@ -213,7 +241,7 @@ real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) end function EW_coast -!> A NS ridge +!> A NS ridge with a cone profile real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -228,7 +256,22 @@ real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) NS_conic_ridge = 1. - rh * cone(r, 0., dlon) end function NS_conic_ridge -!> A circular ridge +!> A NS ridge with an scurve profile +real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lonC !< Longitude of ridge center [degrees_E] + real, intent(in) :: lat0 !< Latitude of ridge end [degrees_N] + real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] + real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] + real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] + real :: r + + r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) + NS_scurve_ridge = 1. - rh * (1. - scurve(r, 0., dlon) ) +end function NS_scurve_ridge + +!> A circular ridge with cutoff conic profile real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -245,4 +288,22 @@ real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness circ_conic_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 end function circ_conic_ridge +!> A circular ridge with cutoff scurve profile +real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) + real, intent(in) :: lon !< Longitude [degrees_E] + real, intent(in) :: lat !< Latitude [degrees_N] + real, intent(in) :: lon0 !< Longitude of center of ring [degrees_E] + real, intent(in) :: lat0 !< Latitude of center of ring [degrees_N] + real, intent(in) :: ring_radius !< Radius of ring [degrees] + real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] + real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] + real :: r + + r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = abs( r - ring_radius) ! Pseudo-distance from a circle + r = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 + r = r * ridge_height ! 0 .. frac_ridge_height + circ_scurve_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 +end function circ_scurve_ridge + end module basin_builder From 8a64e9a247985ddbd8004701032cb85da68d603f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 5 Jun 2020 22:14:56 +0000 Subject: [PATCH 033/256] Fixed missing doxy comment --- src/user/basin_builder.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index 2dccc0d5eb..61b65e0e9c 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -19,7 +19,7 @@ module basin_builder ! This include declares and sets the variable "version". # include "version_variable.h" -character(len=40) :: mdl = "basin_builder" ! This module's name. +character(len=40) :: mdl = "basin_builder" !< This module's name. contains From 74dcb13706d2977d679d4fe7b45cb97f73d6b20a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 18:22:42 -0400 Subject: [PATCH 034/256] +Removed insert_brine and obsoleted 3 parameters Obsoleted the runtime parameters SALT_REJECT_BELOW_ML, MLE_USE_MLD_AVE_BUG and KG_BG_2D_BUG, and deleted the unused subroutine insert_brine. Also deleted 68 variables that have been obsolete for several years. All answers in the MOM6-examples test cases are bitwise identical, but there are changes in the MOM_parameter_doc files. --- src/diagnostics/MOM_obsolete_params.F90 | 136 +----------------- .../lateral/MOM_hor_visc.F90 | 14 +- .../lateral/MOM_mixed_layer_restrat.F90 | 13 +- .../vertical/MOM_bulk_mixed_layer.F90 | 1 - .../vertical/MOM_diabatic_aux.F90 | 126 +--------------- .../vertical/MOM_diabatic_driver.F90 | 24 +--- 6 files changed, 12 insertions(+), 302 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index e669328748..00a30d75ae 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -29,41 +29,12 @@ subroutine find_obsolete_params(param_file) if (.not.is_root_pe()) return - call obsolete_int(param_file, "NTSTEP", & - hint="Instead use DT_THERM to set the thermodynamic time-step.") - - 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'.") - - call obsolete_logical(param_file, "ARITHMETIC_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='ARITHMETIC'.") - - call obsolete_logical(param_file, "HYBRID_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='HYBRID'.") - - call obsolete_logical(param_file, "BT_CONT_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='FROM_BT_CONT'.") - call obsolete_logical(param_file, "ADD_KV_SLOW", & hint="This option is no longer needed, nor supported.") - call obsolete_logical(param_file, "APPLY_OBC_U", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_EAST", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_WEST", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") call obsolete_char(param_file, "OBC_CONFIG", & hint="Instead use OBC_USER_CONFIG and use the new segments protocol.") call obsolete_char(param_file, "READ_OBC_ETA", & @@ -85,113 +56,20 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") enddo - test_logic3 = .true. ; call read_param(param_file,"ENABLE_THERMODYNAMICS",test_logic3) - test_logic = .true. ; call read_param(param_file,"TEMPERATURE",test_logic) - test_logic2 = .false. ; call read_param(param_file,"TEMPERATURE",test_logic2) - if (test_logic .eqv. test_logic2) then ; if (test_logic .eqv. test_logic3) then - call MOM_ERROR(WARNING, "find_obsolete_params: "// & - "TEMPERATURE is an obsolete run-time flag, but is set consistently with \n"//& - " ENABLE_THERMODYNAMICS.") - else - call MOM_ERROR(FATAL, "find_obsolete_params: "// & - "TEMPERATURE is an obsolete run-time flag. Use ENABLE_THERMODYNAMICS instead.") - endif ; endif - - test_logic = test_logic3 ; call read_param(param_file,"NONLINEAR_EOS",test_logic) - if (test_logic .neqv. test_logic3) then - call MOM_error(WARNING, "find_obsolete_params: "// & - "NONLINEAR_EOS is an obsolete option. Instead define " // & - "USE_EOS to use an equation of state to calculate density.") - endif - -! test_logic = .true. ; call read_param(param_file,"USE_RIVER_HEAT_CONTENT",test_logic) -! test_logic2 = .false. ; call read_param(param_file,"USE_RIVER_HEAT_CONTENT",test_logic2) -! if (test_logic .eqv. test_logic2) call MOM_ERROR(FATAL, "find_obsolete_params: "// & -! "USE_RIVER_HEAT_CONTENT, is an obsolete run-time flag.") - -! test_logic = .true. ; call read_param(param_file,"USE_CALVING_HEAT_CONTENT",test_logic) -! test_logic2 = .false. ; call read_param(param_file,"USE_CALVING_HEAT_CONTENT",test_logic2) -! if (test_logic .eqv. test_logic2) call MOM_ERROR(FATAL, "find_obsolete_params: "// & -! "USE_CALVING_HEAT_CONTENT, is an obsolete run-time flag.") - - call obsolete_int(param_file, "NXTOT") - call obsolete_int(param_file, "NYTOT") - call obsolete_int(param_file, "NZ") - call obsolete_int(param_file, "NXPROC") - call obsolete_int(param_file, "NYPROC") - call obsolete_int(param_file, "NXPROC_IO") - call obsolete_int(param_file, "NYPROC_IO") - call obsolete_int(param_file, "NXHALO") - call obsolete_int(param_file, "NYHALO") - call obsolete_int(param_file, "ML_PRESORT_NZ_CONV_ADJ") - - call obsolete_int(param_file, "NIPROC_IO", hint="Use IO_LAYOUT=#,# instead.") - call obsolete_int(param_file, "NJPROC_IO", hint="Use IO_LAYOUT=#,# instead.") - - call obsolete_real(param_file, "BT_COR_SLOW_RATE", 0.0) - call obsolete_real(param_file, "BT_COR_FRAC", 1.0) - call obsolete_logical(param_file, "MASK_MASSLESS_TRACERS", .false.) - call obsolete_logical(param_file, "BT_INCLUDE_UDHDT", .false.) - - call obsolete_logical(param_file, "RIGA_SET_DIFFUSIVITY", .false.) - call obsolete_logical(param_file, "RIGA_ITIDE_BUGS", .false.) - call obsolete_logical(param_file, "RIGA_ENTRAINMENT_FOIBLES", .false.) - call obsolete_logical(param_file, "RIGA_TRACER_DIFFUSE_BUGS", .false.) - call obsolete_logical(param_file, "RIGA_KAPPA_SHEAR_BUGS1", .false.) - call obsolete_logical(param_file, "RIGA_KAPPA_SHEAR_BUGS2", .false.) - call obsolete_logical(param_file, "CONT_PPM_RIGA_BUGS", .false.) - call obsolete_logical(param_file, "USE_REPRODUCING_SUM", .true.) - call obsolete_logical(param_file, "SLOW_BITWISE_GLOBAL_FORCING_SUMS", .false.) - call obsolete_logical(param_file, "ALWAYS_WRITE_GEOM") - call obsolete_real(param_file, "I_ZETA") - - call obsolete_logical(param_file, "REF_COMPRESS_3D") - call obsolete_char(param_file, "COMPRESS_FILE") - call obsolete_char(param_file, "REF_COMPRESS_FILE_TEMP") - call obsolete_char(param_file, "REF_COMPRESS_FILE_SALT") - call obsolete_char(param_file, "REF_COMPRESS_FILE_DEPTH") - call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", "Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") + call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) + call obsolete_logical(param_file, "MLE_USE_MLD_AVE_BUG", .false.) + call obsolete_logical(param_file, "KG_BG_2D_BUG", .false.) - call obsolete_logical(param_file, "OLD_RESTRAT_PARAM", .false.) - call obsolete_real(param_file, "ML_RESTRAT_COEF", 0.0) - call obsolete_logical(param_file, "FULL_THICKNESSDIFFUSE", .true.) - call obsolete_logical(param_file, "DIFFUSE_ISOPYCNALS", .true.) - - call obsolete_logical(param_file, "MOREL_PEN_SW") - call obsolete_logical(param_file, "MANIZZA_PEN_SW") - - call obsolete_logical(param_file, "USE_H2000_SHEAR_MIXING", .false.) - call obsolete_real(param_file, "SHEARMIX_LAT_EQ", 0.0) - call obsolete_real(param_file, "RINO_CRIT_EQ") - call obsolete_real(param_file, "SHEARMIX_RATE_EQ") + call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", "Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") call obsolete_real(param_file, "VSTAR_SCALE_FACTOR", hint="Use EPBL_VEL_SCALE_FACTOR instead.") call obsolete_logical(param_file, "ORIG_MLD_ITERATION", .false.) - call obsolete_logical(param_file, "CONTINUITY_PPM", .true.) - - call obsolete_logical(param_file, "USE_LOCAL_PREF", .true.) - call obsolete_logical(param_file, "USE_LOCAL_PREF_CORRECT", .true.) - test_logic = .false. ; call read_param(param_file, "USE_JACKSON_PARAM", test_logic) - call obsolete_logical(param_file, "RINOMIX", test_logic) - call obsolete_logical(param_file, "NORMALIZED_SUM_OUT", .true.) - - call obsolete_real(param_file, "RLAY_RANGE") - call obsolete_real(param_file, "RLAY_REF") - - call obsolete_real(param_file, "HMIX") call obsolete_real(param_file, "VSTAR_SCALE_COEF") call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") - test_int = -1 ; call read_param(param_file,"ML_RADIATION_CODING",test_int) - if (test_int == 1) call MOM_ERROR(FATAL, "find_obsolete_params: "// & - "ML_RADIATION_CODING is an obsolete option and the code previously "//& - "used by setting it to 1 has been eliminated.") - if (test_int /= -1) call MOM_ERROR(WARNING, "find_obsolete_params: "// & - "ML_RADIATION_CODING is an obsolete option.") - ! Test for inconsistent parameter settings. split = .true. ; test_logic = .false. call read_param(param_file,"SPLIT",split) @@ -200,12 +78,6 @@ subroutine find_obsolete_params(param_file) "find_obsolete_params: #define DYNAMIC_SURFACE_PRESSURE is not yet "//& "implemented without #define SPLIT.") - call obsolete_logical(param_file, "USE_LEGACY_SPLIT", .false.) - - call obsolete_logical(param_file, "FLUX_BT_COUPLING", .false.) - call obsolete_logical(param_file, "READJUST_BT_TRANS", .false.) - call obsolete_logical(param_file, "RESCALE_BT_FACE_AREAS", .false.) - call obsolete_logical(param_file, "APPLY_BT_DRAG", .true.) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index cf993b8aa8..2073ac3a61 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -67,8 +67,6 @@ 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 @@ -1622,11 +1620,6 @@ 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"//& @@ -1840,14 +1833,11 @@ 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 - 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 + if (CS%use_Kh_bg_2d) then 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 + endif ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 3a3a25429c..0a6eac4007 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -56,7 +56,6 @@ module MOM_mixed_layer_restrat !! the mixed-layer [nondim]. real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD used in !! the MLE scheme [nondim]. This simply multiplies MLD wherever used. - logical :: MLE_use_MLD_ave_bug !< If true, do not account for MLD mismatch to interface positions. logical :: debug = .false. !< If true, calculate checksums of fields for debugging. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -182,7 +181,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: ddRho ! A density difference [R ~> kg m-3] 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 + logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -291,7 +290,6 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - proper_averaging = .not. CS%MLE_use_MLD_ave_bug if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -305,8 +303,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$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, & -!$OMP nz,MLD_fast,uDml_diag,vDml_diag,proper_averaging) & +!$OMP res_upscale, nz,MLD_fast,uDml_diag,vDml_diag) & !$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP line_is_empty, keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & @@ -327,8 +324,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then - dh = h(i,j,k) - if (proper_averaging) dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) Rml_av_fast(i,j) = Rml_av_fast(i,j) + dh*rho_ml(i) htot_fast(i,j) = htot_fast(i,j) + dh line_is_empty = .false. @@ -886,9 +882,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) - call get_param(param_file, mdl, "MLE_USE_MLD_AVE_BUG", CS%MLE_use_MLD_ave_bug, & - "If true, do not account for MLD mismatch to interface positions.",& - default=.false.) endif CS%diag => diag diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 358c7a7fa7..3c9d732089 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -110,7 +110,6 @@ module MOM_bulk_mixed_layer !! to set the heat carried by runoff, instead of !! 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. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 85e009bf27..91085047c9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -31,7 +31,7 @@ module MOM_diabatic_aux #include public diabatic_aux_init, diabatic_aux_end -public make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS +public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -383,130 +383,6 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) end subroutine adjust_salt -!> Insert salt from brine rejection into the first layer below the mixed layer -!! which both contains mass and in which the change in layer density remains -!! stable after the addition of salt via brine rejection. -subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses [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(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers - type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous - !! call to diabatic_aux_init - real, intent(in) :: dt !< The thermodynamic time step [T ~> s]. - integer, intent(in) :: id_brine_lay !< The handle for a diagnostic of - !! which layer receivees the brine. - - ! local variables - real :: salt(SZI_(G)) ! The amount of salt rejected from sea ice [ppt R Z ~> gramSalt m-2] - 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)) ! 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)) ! 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] - real, parameter :: s_max = 45.0 ! salinity bound - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - if (.not.associated(fluxes%salt_flux)) return - - !### Injecting the brine into a single layer with a prescribed thickness seems problematic, - ! 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 - EOSdom(:) = EOS_domain(G%HI) - brine_dz = 1.0*GV%m_to_H - - inject_layer(:,:) = nz - - do j=js,je - - salt(:)=0.0 ; dzbr(:)=0.0 - - do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = dt * (1000. * fluxes%salt_flux(i,j)) - endif ; enddo - - do k=1,nz - do i=is,ie - T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) - ! avoid very small thickness - 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, EOSdom) - enddo - - ! First, try to find an interior layer where inserting all the salt - ! will not cause the layer to become statically unstable. - ! Bias towards deeper layers. - - do k=nkmb+1,nz-1 ; do i=is,ie - 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) - if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - dzbr(i) = dzbr(i) + h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j), real(k)) - endif - enddo ; enddo - - ! finally if unable to find a layer to insert, then place in mixed layer - - do k=1,GV%nkml ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - dzbr(i) = dzbr(i) + h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j), real(k)) - endif - enddo ; enddo - - - do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. salt(i) > 0.) then - ! if (dzbr(i)< brine_dz) call MOM_error(FATAL,"insert_brine: failed") - ks = inject_layer(i,j) - cdz = 0.0 - do k=ks,nz - scale = h_2d(i,k) / dzbr(i) - cdz = cdz + h_2d(i,k) - !### I think that the logic of this line is wrong. Moving it down a line - ! would seem to make more sense. - RWH - if (cdz > brine_dz) exit - tv%S(i,j,k) = tv%S(i,j,k) + scale*salt(i) / (GV%H_to_RZ * h_2d(i,k)) - enddo - endif - enddo - - enddo - - if (CS%id_brine_lay > 0) call post_data(CS%id_brine_lay, inject_layer, CS%diag) - -end subroutine insert_brine - !> This is a simple tri-diagonal solver for T and S. !! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0bd3138670..bc38698de5 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -12,7 +12,7 @@ module MOM_diabatic_driver use MOM_CVMix_shear, only : CVMix_shear_is_used use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS -use MOM_diabatic_aux, only : make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS +use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut use MOM_diabatic_aux, only : set_pen_shortwave use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -154,7 +154,6 @@ module MOM_diabatic_driver integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that !! must be valid for the diffusivity calculations. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport - logical :: salt_reject_below_ML !< If true, add salt below mixed layer (layer mode only) logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debugConservation !< If true, monitor conservation and extrema. @@ -175,7 +174,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_subMLN2 = -1, id_brine_lay = -1 + integer :: id_subMLN2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -2075,10 +2074,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml,ebml, G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, & - dt*CS%ML_mix_first, CS%id_brine_lay) - else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & @@ -2468,10 +2463,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & - CS%id_brine_lay) - ! Keep salinity from falling below a small but positive threshold. ! This constraint is needed for SIS1 ice model, which can extract ! more salt than is present in the ocean. SIS2 does not suffer @@ -3494,17 +3485,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') endif - call get_param(param_file, mdl, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & - "If true, place salt from brine rejection below the mixed layer, "// & - "into the first non-vanished layer for which the column remains stable", & - 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') - endif - - ! diagnostics for tendencies of temp and saln due to diabatic processes ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil From 2ec0f5166ff9da7644bc92906a6ac7d930858da6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 18:26:35 -0400 Subject: [PATCH 035/256] +(*)Set the default of GILL_EQUATORIAL_LD to True Changed the default value of GILL_EQUATORIAL_LD to True. This could change answers in some test cases where GILL_EQUATORIAL_LD is not set explicitly, and there are changes to the MOM_parameter_doc files. --- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 37e549f3f1..2f8e55ea7e 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1163,13 +1163,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif - !### Change the default of GILL_EQUATORIAL_LD to True. call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & "If true, uses Gill's definition of the baroclinic "//& "equatorial deformation radius, otherwise, if false, use "//& "Pedlosky's definition. These definitions differ by a factor "//& "of 2 in front of the beta term in the denominator. Gill's "//& - "is the more appropriate definition.", default=.false.) + "is the more appropriate definition.", default=.true.) if (Gill_equatorial_Ld) then oneOrTwo = 2.0 endif From 6bd8659eaa2b083810b6f7862e8053b13b8a6156 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 18:29:39 -0400 Subject: [PATCH 036/256] +Removed KELVIN_WAVE_2018_ANSWERS Removed the runtime parameter KELVIN_WAVE_2018_ANSWERS, which is no longer used for anything. All answers are bitwise identical, but there are changes to the MOM_parameter_doc files. --- src/user/Kelvin_initialization.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 6eade35bad..e57dfa940a 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -42,9 +42,6 @@ module Kelvin_initialization real :: F_0 !< Coriolis parameter real :: rho_range !< Density range real :: rho_0 !< Mean density - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use expressions that give - !! rotational symmetry and eliminate apparent bugs. end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -98,10 +95,6 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) 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, "KELVIN_WAVE_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 give rotational "//& - "symmetry and eliminate apparent bugs.", default=default_2018_answers) if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & default=2.0, do_not_log=.true.) From 2864735c2e78bba4fe211b24c272171cdafae8d7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 18:33:42 -0400 Subject: [PATCH 037/256] +(*)Set the default of OBC_RADIATION_MAX to 1.0 Changed the default value of OBC_RADIATION_MAX from 10.0 to 1.0, which makes much more physical sense. This will change answers in test cases where open boundary conditions are used and OBC_RADIATION_MAX is not set explicitly, and there are changes to the MOM_parameter_doc files for cases with open boundary conditions. --- 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 58e3fb63fc..076acd9fe4 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -502,7 +502,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "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="nondim", default=10.0) !### Should the default be changed to 1.0? + units="nondim", default=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 "//& From af33ba4df3da1698c0da985480fd8cfeda0c7f66 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 18:36:15 -0400 Subject: [PATCH 038/256] +(*)Set the default of USE_PSURF_IN_EOS to True Changed the default value of USE_PSURF_IN_EOS to True. This could change answers in some test cases with sea ice where USE_PSURF_IN_EOS is not set explicitly, and there are changes to the MOM_parameter_doc files. --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a044f95893..a169d92cb0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1908,7 +1908,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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. + "in equation of state calculations.", default=.true.) 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 "//& From fa40074eb70db124d16389b493cd7f68ce4a26ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 19:25:10 -0400 Subject: [PATCH 039/256] +(*)Set the default of DEFAULT_2018_ANSWERS to False Changed the default of DEFAULT_2018_ANSWERS to False. This in turn changes the default values of 13 other pamarmeters, and could change answers in some test cases where DEFAULT_2018_ANSWERS or the dependent parameters are not set explicitly. By design, the answers in MOM6-examples test suite are bitwise identical, but they could change in other cases and there are changes to the MOM_parameter_doc files. --- config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 | 2 +- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- src/ALE/MOM_ALE.F90 | 2 +- src/ALE/MOM_regridding.F90 | 2 +- src/core/MOM.F90 | 2 +- src/core/MOM_barotropic.F90 | 2 +- src/core/MOM_open_boundary.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 2 +- src/initialization/MOM_state_initialization.F90 | 4 ++-- src/initialization/MOM_tracer_initialization_from_Z.F90 | 2 +- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 4 ++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 2 +- src/parameterizations/vertical/MOM_opacity.F90 | 2 +- src/parameterizations/vertical/MOM_regularize_layers.F90 | 2 +- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 2 +- src/parameterizations/vertical/MOM_set_viscosity.F90 | 2 +- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/user/Idealized_Hurricane.F90 | 2 +- src/user/Kelvin_initialization.F90 | 4 ---- 25 files changed, 26 insertions(+), 30 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 78811084fd..bfbcdc856c 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1496,7 +1496,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) endif 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.) + default=.false.) call get_param(param_file, mdl, "SURFACE_FORCING_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 a simpler expression to calculate gustiness.", & diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 173d417ff3..aecdf75d17 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1648,7 +1648,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units="nondim", default=0.0) 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.) + default=.false.) call get_param(param_file, mdl, "WIND_GYRES_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 for the gyre friction velocities "//& diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 5f0c8839b9..470ee4ded4 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -196,7 +196,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "extrapolated instead of piecewise constant", 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.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_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 "//& diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index ed6e66e0ae..889e10e32d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -260,7 +260,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m 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.) + default=.false.) 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 "//& diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a169d92cb0..727a94e0a1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1968,7 +1968,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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.) + default=.false.) 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 "//& diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e6f11987a2..9b5a2c1a57 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4074,7 +4074,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, units="nondim", default=1.0) 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.) + default=.false.) call get_param(param_file, mdl, "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.", & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 076acd9fe4..1f973f39ca 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -619,7 +619,7 @@ subroutine initialize_segment_data(G, OBC, PF) 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.) + default=.false.) 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 "//& diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 82be08100e..81f1e3cf15 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1499,7 +1499,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag "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.) + default=.false.) 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 "//& diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 03de6405fe..368a6b773b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3032,7 +3032,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) 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.) + default=.false.) 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 "//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f52e2aca47..af8bb51e65 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1130,7 +1130,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) 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.) + default=.false.) 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 "//& @@ -2110,7 +2110,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param default=.true., do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 5d585466c8..6011ebb9f8 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -114,7 +114,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ default="PLM") call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) 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 "//& diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2073ac3a61..de0de2e1d3 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1412,7 +1412,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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.) + default=.false.) call get_param(param_file, mdl, "HOR_VISC_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 "//& diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 2f8e55ea7e..49ac3648db 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1247,7 +1247,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%cg1(isd:ied,jsd:jed)) ; CS%cg1(:,:) = 0.0 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.) + default=.false.) 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 "//& diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 3819dce047..e76007a8e5 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1911,7 +1911,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, 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.) + default=.false.) 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 "//& diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 438236fc2a..5088a92d6e 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -204,7 +204,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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.) + default=.false.) 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 "//& @@ -442,7 +442,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) 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.) + default=.false.) 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 "//& diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index e3c33bd1c8..0ae46e225e 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2027,7 +2027,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "decreases the PBL diffusivity.", units="nondim", default=1.0) 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.) + default=.false.) call get_param(param_file, mdl, "EPBL_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 "//& diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 8e4acf1142..7cbbc33441 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1048,7 +1048,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) 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.) + default=.false.) call get_param(param_file, mdl, "OPTICS_2018_ANSWERS", optics%answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated expressions for "//& diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 00c8258fb7..56d16a8613 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -921,7 +921,7 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) "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.) + default=.false.) 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 "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9d03b11f7b..52e83bf834 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1942,7 +1942,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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.) + default=.false.) call get_param(param_file, mdl, "SET_DIFF_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 "//& diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f208b9fe09..d4d3251885 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1875,7 +1875,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS 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.) + default=.false.) call get_param(param_file, mdl, "SET_VISC_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 "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 801e573023..4b0ead8b0d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -268,7 +268,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, 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.) + default=.false.) call get_param(param_file, mdl, "TIDAL_MIXING_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 "//& diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6df0beb5e3..146acc4394 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1574,7 +1574,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call log_version(param_file, mdl, version, "") 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.) + default=.false.) 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 arbitrary "//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 30cdec3b37..c3c46d85a8 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -180,7 +180,7 @@ logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diab trim(remappingSchemesDoc), default=remappingDefaultScheme) 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.) + default=.false.) 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 "//& diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index a8ec1d06ff..5d5f259dd7 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -170,7 +170,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "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.) + default=.false.) 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 "//& diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index e57dfa940a..a3215294fc 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -57,7 +57,6 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) ! Local variables logical :: register_Kelvin_OBC - logical :: default_2018_answers character(len=40) :: mdl = "register_Kelvin_OBC" !< This subroutine's name. character(len=32) :: casename = "Kelvin wave" !< This case's name. character(len=200) :: config @@ -92,9 +91,6 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) CS%coast_offset1 = CS%coast_offset1 * 1.e3 ! Convert to m CS%coast_offset2 = CS%coast_offset2 * 1.e3 ! Convert to m endif - 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.) if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & default=2.0, do_not_log=.true.) From 692a4b706be7e2a2ca6e94827242f2dd4bfd6cc6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jun 2020 20:48:57 -0400 Subject: [PATCH 040/256] +(*)Set the default of GUST_CONST to 0 Pa Changed the default value of GUST_CONST to 0 from 0.02 Pa. This could change answers in some test cases where GUST_CONST is not set explicitly, and there are changes to the MOM_parameter_doc files. --- config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 | 2 +- config_src/ice_solo_driver/MOM_surface_forcing.F90 | 2 +- config_src/ice_solo_driver/user_surface_forcing.F90 | 2 +- config_src/mct_driver/mom_surface_forcing_mct.F90 | 3 +-- config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 | 2 +- config_src/solo_driver/MESO_surface_forcing.F90 | 3 +-- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- config_src/solo_driver/Neverland_surface_forcing.F90 | 3 +-- config_src/solo_driver/user_surface_forcing.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 3 +-- src/user/Idealized_Hurricane.F90 | 1 - 11 files changed, 10 insertions(+), 15 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index bfbcdc856c..a94cd51a8d 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1483,7 +1483,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 8e218fb6c4..80e5d22324 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -1139,7 +1139,7 @@ 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) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) 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/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 1b372bf44b..bb2580980b 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -320,7 +320,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) 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) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index f37fb76266..5b03b97549 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1245,8 +1245,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 763195cce6..a780bcb24d 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1245,7 +1245,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index cc0939ac17..7d3689dc21 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -243,8 +243,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "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, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index aecdf75d17..6fc4f94604 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1729,7 +1729,7 @@ 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) + units="Pa", default=0.0, 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.) diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index a53eaec27e..e624b8d7c2 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -249,8 +249,7 @@ subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) "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, "GUST_CONST", CS%gust_const, & -! "The background gustiness in the winds.", units="Pa", & -! default=0.02) +! "The background gustiness in the winds.", units="Pa", default=0.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index a95046fe20..2f071b7079 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -272,7 +272,7 @@ subroutine USER_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, "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) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 88e7ae45d5..3debe9121a 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -222,8 +222,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) "The rate of change of density with temperature.", & units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 5d5f259dd7..25e60d4895 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -189,7 +189,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "The background gustiness in the winds.", units="Pa", & default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) - if (CS%BR_BENCH) then CS%rho_a = 1.2*US%kg_m3_to_R endif From 7b2d81ec8200a1361b3db8e3ef5c073478791f60 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:07:02 -0400 Subject: [PATCH 041/256] +(*)Changed default for BULKML_CONV_MOMENTUM_BUG Changed the default value of BULKML_CONV_MOMENTUM_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases with a bulk mixed layer if BULKML_CONV_MOMENTUM_BUG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 3c9d732089..021ed4a26f 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3578,7 +3578,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 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.) + "during mixedlayer convection.", default=.false.) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & CS%allow_clocks_in_omp_loops, & From 470e75d60c426319a762d56aab77992f56fc3587 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:09:18 -0400 Subject: [PATCH 042/256] +(*)Changed default for ML_RAD_BUG to false Changed the default value of ML_RAD_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases with a bulk mixed layer and ML_RADIATION set to true but ML_RAD_BUG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 52e83bf834..bdae9f4ed0 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1965,7 +1965,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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 "//& - "deposition lenthscale (in m).", default=.true.) + "deposition lenthscale (in m).", default=.false.) call get_param(param_file, mdl, "ML_RAD_KD_MAX", CS%ML_rad_kd_max, & "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& From 84d3b5ac53d2f6a7013c33903706371b1666dbb1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:17:10 -0400 Subject: [PATCH 043/256] +(*)Changed default for USE_MLD_ITERATION to true Changed the default value of USE_MLD_ITERATION to true. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases that use ePBL if USE_MLD_ITERATION is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 0ae46e225e..c27270c432 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2154,11 +2154,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=0.0) !/ Mixing Length Options - !### THIS DEFAULT SHOULD BECOME TRUE. call get_param(param_file, mdl, "USE_MLD_ITERATION", CS%Use_MLD_iteration, & "A logical that specifies whether or not to use the "//& "distance to the bottom of the actively turbulent boundary "//& - "layer to help set the EPBL length scale.", default=.false.) + "layer to help set the EPBL length scale.", default=.true.) call get_param(param_file, mdl, "EPBL_TRANSITION_SCALE", CS%transLay_scale, & "A scale for the mixing length in the transition layer "//& "at the edge of the boundary layer as a fraction of the "//& From 2129f6079e13be7137d4409c953d7ed8eb8e6417 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:17:46 -0400 Subject: [PATCH 044/256] +(*)Changed the default for KAPPA_SHEAR_ITER_BUG Changed the defaults of KAPPA_SHEAR_ITER_BUG and KAPPA_SHEAR_ALL_LAYER_TKE_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases that use the MOM_kappa_shear code if these parameters are not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 107a80b058..01b2cdacdd 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -2098,12 +2098,12 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & "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 > 1 m.", default=.true.) + "The bug causes undercorrections when dz > 1 m.", default=.false.) 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.) + default=.false.) ! 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 83de843ef750331ceb14d1cee430813d8f51b133 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:18:42 -0400 Subject: [PATCH 045/256] +Obsoleted CORRECT_DENSITY Obsoleted the runtime parameter CORRECT_DENSITY, with the solutions using MOM_entrain_diffusive being the same as if that had been set to True. All answers in the MOM6-examples test cases are bitwise identical, but there are changes in the MOM_parameter_doc files. --- src/diagnostics/MOM_obsolete_params.F90 | 1 + .../vertical/MOM_entrain_diffusive.F90 | 19 +++++-------------- 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 00a30d75ae..dd8f6ede75 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -61,6 +61,7 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) call obsolete_logical(param_file, "MLE_USE_MLD_AVE_BUG", .false.) call obsolete_logical(param_file, "KG_BG_2D_BUG", .false.) + call obsolete_logical(param_file, "CORRECT_DENSITY", .true.) call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", "Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 1be3421534..bceaac6d80 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -29,8 +29,6 @@ module MOM_entrain_diffusive type, public :: entrain_diffusive_CS ; private logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! GV%nk_rho_varies variable density mixed & buffer layers. - logical :: correct_density !< If true, the layer densities are restored toward - !! their target variables by the diapycnal mixing. integer :: max_ent_it !< The maximum number of iterations that may be used to !! calculate the diapycnal entrainment. real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values @@ -198,7 +196,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 + logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate 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. @@ -242,8 +240,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (CS%id_diff_work > 0) allocate(diff_work(G%isd:G%ied,G%jsd:G%jed,nz+1)) if (CS%id_Kd > 0) allocate(Kd_eff(G%isd:G%ied,G%jsd:G%jed,nz)) - correct_density = (CS%correct_density .and. associated(tv%eqn_of_state)) - if (correct_density) then + if (associated(tv%eqn_of_state)) then pres(:) = tv%P_Ref else pres(:) = 0.0 @@ -252,8 +249,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,EOSdom, & - !$OMP diff_work,g_2dt, kb_out) & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,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, & !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & @@ -686,7 +682,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! Calculate the layer thicknesses after the entrainment to constrain the ! corrective fluxes. - if (correct_density) then + if (associated(tv%eqn_of_state)) then do i=is,ie h_guess(i,1) = (h(i,j,1) - Angstrom) + (eb(i,j,1) - ea(i,j,2)) h_guess(i,nz) = (h(i,j,nz) - Angstrom) + (ea(i,j,nz) - eb(i,j,nz-1)) @@ -813,7 +809,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo endif - endif ! correct_density + endif ! associated(tv%eqn_of_state)) if (CS%id_Kd > 0) then Idt = GV%H_to_Z**2 / dt @@ -2118,11 +2114,6 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re ! Set default, read and log parameters if (.not.just_read) call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "CORRECT_DENSITY", CS%correct_density, & - "If true, and USE_EOS is true, the layer densities are "//& - "restored toward their target values by the diapycnal "//& - "mixing, as described in Hallberg (MWR, 2000).", & - default=.true., do_not_log=just_read) call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) From 47c810159429ffacbd8d6f51b152f22b1a16ac41 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:19:13 -0400 Subject: [PATCH 046/256] +(*)Changed default for SLOSHING_IC_BUG to false Changed the default value of SLOSHING_IC_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in the sloshing test case if SLOSHING_IC_BUG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/user/sloshing_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index e099d808d5..a0dee01b55 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -89,7 +89,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p units='m', default=75.0, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "SLOSHING_IC_BUG", use_IC_bug, & "If true, use code with a bug to set the sloshing initial conditions.", & - default=.true., do_not_log=just_read) + default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From 101a490ff0192f6db9b50ae0ea71a473fe5f9b98 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:20:48 -0400 Subject: [PATCH 047/256] +(*)Changed the default for USE_GM_WORK_BUG Changed the default value of USE_GM_WORK_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases that use interface height diffusion and MEKE for diffusivities or viscosities where USE_GM_WORK_BUG is not set explicitly. There are changes to the MOM_parameter_doc files. --- 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 e76007a8e5..7d5fc8b846 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1929,7 +1929,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) 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.) + default=.false.) 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) From 337af396567030bf0702a7c989088ecc5da01289 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:21:31 -0400 Subject: [PATCH 048/256] +(*)Changed the default for MEKE_ALPHA_RHINES Changed the default value of MEKE_ALPHA_RHINES and MEKE_ALPHA_EADY from 0.05 to 0.0, following the pattern for the defaults for other MEKE parameters. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases that use MEKE for diffusivities or viscosities where MEKE_ALPHA_RHINES or MEKE_ALPHA_EADY are not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/lateral/MOM_MEKE.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index e5a4b3de8a..dbb0a41506 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1154,11 +1154,11 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_ALPHA_RHINES", CS%aRhines, & "If positive, is a coefficient weighting the Rhines scale "//& "in the expression for mixing length used in MEKE-derived diffusivity.", & - units="nondim", default=0.05) + units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_EADY", CS%aEady, & "If positive, is a coefficient weighting the Eady length scale "//& "in the expression for mixing length used in MEKE-derived diffusivity.", & - units="nondim", default=0.05) + units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_ALPHA_FRICT", CS%aFrict, & "If positive, is a coefficient weighting the frictional arrest scale "//& "in the expression for mixing length used in MEKE-derived diffusivity.", & From 91454d70a1cb2fa02cb55b93ee72dafa9aecbfa4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:22:14 -0400 Subject: [PATCH 049/256] +(*)Changed the default for USE_LAND_MASK_FOR_HVISC Changed the default value of USE_LAND_MASK_FOR_HVISC to True. All answers in the MOM6-examples test suite are bitwise identical, but this could change answers in some test cases where USE_LAND_MASK_FOR_HVISC is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index de0de2e1d3..7c1405308f 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1597,9 +1597,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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.) + "values over land or outside of the domain.", default=.true.) 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, & From 85c86fa398e393d80a3dfa7449466dd7681a1357 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:26:32 -0400 Subject: [PATCH 050/256] +(*)Changed default for INTERPOLATE_RES_FN to false Changed the default value of INTERPOLATE_RES_FN to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in some test cases that use a resolution function to scale the viscosities or diffusivities if INTERPOLATE_RES_FN is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 49ac3648db..0f07701eda 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1154,7 +1154,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, interpolate the resolution function to the "//& "velocity points from the thickness points; otherwise "//& "interpolate the wave speed and calculate the resolution "//& - "function independently at each point.", default=.true.) + "function independently at each point.", default=.false.) if (CS%interpolate_Res_fn) then if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& From 6ecd1c4f312e868f0912d35f57cac8634446d83b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:27:36 -0400 Subject: [PATCH 051/256] +(*)Changed the default for REMAP_UV_USING_OLD_ALG Changed the default value of REMAP_UV_USING_OLD_ALG to False. All answers in the MOM6-examples test suite are bitwise identical, but this could change answers in some test cases with ALE remapping where REMAP_UV_USING_OLD_ALG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 470ee4ded4..c4bf6ea7f0 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -163,12 +163,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) CS%show_call_tree = callTree_showQuery() if (CS%show_call_tree) call callTree_enter("ALE_init(), MOM_ALE.F90") - call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", & - CS%remap_uv_using_old_alg, & + call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & "If true, uses the old remapping-via-a-delta-z method for "//& "remapping u and v. If false, uses the new method that remaps "//& "between grids described by an old and new thickness.", & - default=.true.) + default=.false.) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) From c3e187d475ba6a47fa0b02991a5fd29c328c6c2d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:29:51 -0400 Subject: [PATCH 052/256] +Set default for COORD_CONFIG to "none" Set the default for COORD_CONFIG (to "none"). Because this had previously been mandatory, all answers are bitwise identical in all cases, but there are changes in the MOM_parameter_doc files. --- src/initialization/MOM_coord_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 58f58fe828..5b2bd7130f 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -80,7 +80,7 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept " \t ts_profile - use temperature and salinity profiles \n"//& " \t\t (read from COORD_FILE) to set layer densities. \n"//& " \t USER - call a user modified routine.", & - fail_if_missing=.true.) + default="none") select case ( trim(config) ) case ("gprime") call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) From 449b3c45b2e941e5aaf385055df76c087d3ff0de Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:30:15 -0400 Subject: [PATCH 053/256] +Set a default for THICKNESS_CONFIG Set defaults for THICKNESS_CONFIG (to "uniform"), and for INITIAL_U_CONST and INITIAL_V_CONST (to 0 m/s). Because these had previously been mandatory, all answers are bitwise identical in all cases, but there are changes in the MOM_parameter_doc files. --- src/initialization/MOM_state_initialization.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index af8bb51e65..c5e240d9dd 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -269,7 +269,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t soliton - Equatorial Rossby soliton. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & - fail_if_missing=new_sim, do_not_log=just_read) + default="uniform", do_not_log=just_read) select case (trim(config)) case ("file") call initialize_thickness_from_file(h, G, GV, US, PF, .false., just_read_params=just_read) @@ -1368,10 +1368,10 @@ subroutine initialize_velocity_uniform(u, v, G, US, param_file, just_read_params call get_param(param_file, mdl, "INITIAL_U_CONST", initial_u_const, & "A initial uniform value for the zonal flow.", & - units="m s-1", scale=US%m_s_to_L_T, fail_if_missing=.not.just_read, do_not_log=just_read) + default=0.0, units="m s-1", scale=US%m_s_to_L_T, do_not_log=just_read) call get_param(param_file, mdl, "INITIAL_V_CONST", initial_v_const, & "A initial uniform value for the meridional flow.", & - units="m s-1", scale=US%m_s_to_L_T, fail_if_missing=.not.just_read, do_not_log=just_read) + default=0.0, units="m s-1", 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. From ef6a4252282d447c6984299d6470c1f7fa05c557 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:31:32 -0400 Subject: [PATCH 054/256] +(*)Changed the default of FIX_USTAR_GUSTLESS_BUG Changed the default value of FIX_USTAR_GUSTLESS_BUG to True and the default of USE_NET_FW_ADJUSTMENT_SIGN_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this could change answers in some test case where these parameters are not set explicitly. There are changes to the MOM_parameter_doc files. --- config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 | 4 ++-- config_src/mct_driver/mom_surface_forcing_mct.F90 | 4 ++-- config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 | 4 ++-- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index a94cd51a8d..c9cb227697 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1325,7 +1325,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.true.) + "the net fresh-water.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1503,7 +1503,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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.) + default=.true.) ! 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 5b03b97549..272e0ebd18 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1095,7 +1095,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.false.) + "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1258,7 +1258,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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.) + default=.true.) ! 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 a780bcb24d..5dcfecc4a3 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1094,7 +1094,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.false.) + "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1258,7 +1258,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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.) + default=.true.) ! 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 6fc4f94604..425c99c403 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1732,7 +1732,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units="Pa", default=0.0, 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.) + default=.true.) 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.) From b3649255c0d84cb6ea0f0a6821d5d17d0ee50f75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 08:55:40 -0400 Subject: [PATCH 055/256] +Set defaults for WIND_CONFIG and BUOY_CONFIG Set defaults for WIND_CONFIG and BUOY_CONFIG to "zero". Because these had previously been mandatory, all answers are bitwise identical in all cases, but there are changes in the MOM_parameter_doc files. --- config_src/ice_solo_driver/MOM_surface_forcing.F90 | 4 ++-- config_src/solo_driver/MOM_surface_forcing.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 80e5d22324..292bc65b18 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -1007,7 +1007,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & "The character string that indicates how buoyancy forcing "//& "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", fail_if_missing=.true.) + "(linear), (USER), and (NONE).", default="zero") if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & "The file with the downward longwave heat flux, in "//& @@ -1046,7 +1046,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing "//& "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) + "(1gyre), (gyres), (zero), and (USER).", default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 425c99c403..6b8b0f9497 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1459,7 +1459,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & "The character string that indicates how buoyancy forcing "//& "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), (BFB) and (NONE).", fail_if_missing=.true.) + "(linear), (USER), (BFB) and (NONE).", default="zero") if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "ARCHAIC_OMIP_FORCING_FILE", CS%archaic_OMIP_file, & "If true, use the forcing variable decomposition from "//& @@ -1601,7 +1601,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing "//& "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) + "(1gyre), (gyres), (zero), and (USER).", default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& From d4a39ffdd78a71ad7110be4ab88b47d23f4b81ab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 10:38:12 -0400 Subject: [PATCH 056/256] +(*)Changed WINDSTRESS_STAGGER to WIND_STAGGER Changed the parameter to specify the staggering of wind variables in input files to drive ocean only runs from WINDSTRESS_STAGGER to WIND_STAGGER, with a default of "C". This is now consistent with the equivalent parameter name and default used in the coupled runs. WINDSTRESS_STAGGER has been obsoleted, and a new optional warning_val argument has been added to obsolete_char, patterned after the warning arguments to the obsolete parameter routines for other types. All answers in the MOM6-examples test suite are bitwise identical, but it is possible for ocean-only cases reading in A-grid wind stresses to give a fatal error if their parameters are not updated, and there are changes to the MOM_parameter_doc files. --- .../ice_solo_driver/MOM_surface_forcing.F90 | 4 +-- .../solo_driver/MOM_surface_forcing.F90 | 4 +-- src/diagnostics/MOM_obsolete_params.F90 | 30 +++++++++++++++---- 3 files changed, 28 insertions(+), 10 deletions(-) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 292bc65b18..4b58af618d 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -1057,10 +1057,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & + call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") + default="C") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & "A value by which the wind stresses in WIND_FILE are rescaled.", & default=1.0, units="nondim") diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 6b8b0f9497..f7ef6d2c78 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1612,10 +1612,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & + call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") + default="C") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & "A value by which the wind stresses in WIND_FILE are rescaled.", & default=1.0, units="nondim") diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index dd8f6ede75..a38f5a4b54 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -62,8 +62,11 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "MLE_USE_MLD_AVE_BUG", .false.) call obsolete_logical(param_file, "KG_BG_2D_BUG", .false.) call obsolete_logical(param_file, "CORRECT_DENSITY", .true.) + call obsolete_char(param_file, "WINDSTRESS_STAGGER", warning_val="C", & + hint="Use WIND_STAGGER instead.") - call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", "Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") + call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", & + hint="Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") call obsolete_real(param_file, "VSTAR_SCALE_FACTOR", hint="Use EPBL_VEL_SCALE_FACTOR instead.") call obsolete_logical(param_file, "ORIG_MLD_ITERATION", .false.) @@ -138,21 +141,36 @@ subroutine obsolete_logical(param_file, varname, warning_val, hint) end subroutine obsolete_logical !> Test for presence of obsolete STRING in parameter file. -subroutine obsolete_char(param_file, varname, hint) +subroutine obsolete_char(param_file, varname, warning_val, hint) type(param_file_type), intent(in) :: param_file !< Structure containing parameter file data. character(len=*), intent(in) :: varname !< Name of obsolete STRING parameter. + character(len=*), optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. ! Local variables character(len=200) :: test_string, hint_msg + logical :: only_warn test_string = ''; call read_param(param_file, varname, test_string) hint_msg = " " ; if (present(hint)) hint_msg = hint - if (len_trim(test_string) > 0) call MOM_ERROR(FATAL, & - "MOM_obsolete_params: "//trim(varname)// & - " is an obsolete run-time flag, and should not be used. "// & - trim(hint_msg)) + if (len_trim(test_string) > 0) then + only_warn = .false. + if (present(warning_val)) then ! Check if test_string and warning_val are the same. + if (len_trim(warning_val) == len_trim(test_string)) then + if (index(trim(test_string), trim(warning_val)) == 1) only_warn = .true. + endif + endif + if (only_warn) then + call MOM_ERROR(WARNING, & + "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag. "//trim(hint_msg)) + else + call MOM_ERROR(FATAL, & + "MOM_obsolete_params: "//trim(varname)// & + " is an obsolete run-time flag, and should not be used. "//trim(hint_msg)) + endif + endif end subroutine obsolete_char !> Test for presence of obsolete REAL in parameter file. From 41df5bb1c704588e821ed0aab077567729af1b03 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 11:16:13 -0400 Subject: [PATCH 057/256] +(*)Set the default for KD to 0 m2 s-1 Set the default value for KD to 0 m2 s-1, and the default value for KD_KAPPA_SHEAR_0 to the greater of KD and 1e-7 m2 s-1. Because Kd did not previously have a default, this can not change answers, but the new default for KD_KAPPA_SHEAR_0 (which had previously been Kd or 1e-7 m2 s-1 if KD is not set) could change answers is KD_KAPPA_SHEAR_0 is not set explicitly and KD is set explicitly to a value that is less than 1e-7 m2 s-1. All answers in the MOM-examples test suite are bitwise identical, but there are changes to the MOM_parameter_doc files. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 4 ++-- .../vertical/MOM_diabatic_driver.F90 | 4 ++-- .../vertical/MOM_entrain_diffusive.F90 | 11 ++++++----- src/parameterizations/vertical/MOM_kappa_shear.F90 | 6 +++--- .../vertical/MOM_set_diffusivity.F90 | 3 +-- 5 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 779bee6fcf..6ad6337e28 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -126,7 +126,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables - real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set prandtl + real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl ! number unless it is provided as a parameter real :: prandtl_bkgnd_comp ! Kv/CS%Kd. Gets compared with user-specified prandtl_bkgnd. @@ -147,7 +147,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& - "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV", Kv, & "The background kinematic viscosity in the interior. "//& diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index bc38698de5..9db2b4742b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3189,7 +3189,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure - real :: Kd + real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] integer :: num_mode logical :: use_temperature, differentialDiffusion @@ -3320,7 +3320,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "KD_MIN_TR were operating.", default=.true.) if (CS%mix_boundary_tracers) then - call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) + call get_param(param_file, mdl, "KD", Kd, default=0.0) call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & "A minimal diffusivity that should always be applied to "//& "tracers, especially in massless layers near the bottom. "//& diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index bceaac6d80..4ed0dcc6bf 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -2093,7 +2093,8 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re !! any diagnostics ! Local variables - real :: decay_length, dt, Kd + real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] + real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] logical :: just_read ! If true, just read parameters but do nothing else. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2117,15 +2118,15 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) -! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] - call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) + ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] + call get_param(param_file, mdl, "KD", Kd, default=0.0) call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & fail_if_missing=.true., do_not_log=just_read) -! CS%Tolerance_Ent = MAX(100.0*GV%Angstrom_H,1.0e-4*sqrt(dt*Kd)) ! call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, do_not_log=just_read) + units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & + do_not_log=just_read) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 01b2cdacdd..12d9bfc9c0 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -2019,12 +2019,12 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & units="nondim", default=50) - call get_param(param_file, mdl, "KD", KD_normal, default=1.0e-7, do_not_log=.true.) + call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& - "diffusivities. Defaults to value of KD.", & - units="m2 s-1", default=KD_normal, scale=US%m2_s_to_Z2_T, unscaled=kappa_0_unscaled) + "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & + units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, unscaled=kappa_0_unscaled) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index bdae9f4ed0..f2d4484c78 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2060,8 +2060,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& - "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, & - fail_if_missing=.true.) + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) 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) From 7260088a4c932291d977ab27e331a10ef887c8dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 11:55:22 -0400 Subject: [PATCH 058/256] +Set the default for S_REF to 35 ppt Set the default value of S_REF uniformly to 35 ppt. In some cases this had been the default before, but in others there was no default and this was a mandatory parameter, so the answers do not change, but there are changes to the MOM_parameter_doc files. --- src/user/DOME2d_initialization.F90 | 14 +++++++------- src/user/Rossby_front_2d_initialization.F90 | 4 ++-- src/user/adjustment_initialization.F90 | 5 +++-- src/user/dense_water_initialization.F90 | 12 +++++++----- src/user/sloshing_initialization.F90 | 13 ++++++------- 5 files changed, 25 insertions(+), 23 deletions(-) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 6d307f843a..923801db2d 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -257,9 +257,9 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & default=0.2, do_not_log=.true.) - call get_param(param_file, mdl,"S_REF",S_ref,'Reference salinity',units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Refernce temperature',units='C', & + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='degC', & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range', & units='1e-3', default=2.0, do_not_log=just_read) @@ -415,10 +415,10 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & default=0.2, do_not_log=.true.) - call get_param(param_file, mdl,"S_REF",S_ref) - call get_param(param_file, mdl,"T_REF",T_ref) - call get_param(param_file, mdl,"S_RANGE",S_range,default=2.0) - call get_param(param_file, mdl,"T_RANGE",T_range,default=0.0) + call get_param(param_file, mdl, "S_REF", S_ref, default=35.0) + call get_param(param_file, mdl, "T_REF", T_ref) + call get_param(param_file, mdl, "S_RANGE", S_range, default=2.0) + call get_param(param_file, mdl, "T_RANGE", T_range, default=0.0) ! Set the inverse damping rate as a function of position diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 80b3bc6d94..ed0082c397 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -135,8 +135,8 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & 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,"S_REF",S_ref,'Reference salinity', units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature',units='C',& fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range',& diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index e4816a1338..0b9d4409f8 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -70,9 +70,10 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! Parameters used by main model initialization if (.not.just_read) call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl,"S_REF",S_ref,fail_if_missing=.true.,do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness,'Minimum layer thickness', & - units='m', default=1.0e-3, do_not_log=just_read, scale=US%m_to_Z) + default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) ! Parameters specific to this experiment configuration call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index d591db30fb..468a5649fe 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -118,10 +118,12 @@ subroutine dense_water_initialize_TS(G, GV, param_file, eqn_of_state, T, S, h, j call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & "Depth of unstratified mixed layer as a fraction of the water column.", & units="nondim", default=default_mld, do_not_log=just_read) - - call get_param(param_file, mdl, "S_REF", S_ref, do_not_log=.true.) - call get_param(param_file, mdl, "S_RANGE", S_range, do_not_log=.true.) - call get_param(param_file, mdl, "T_REF", T_ref, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', units='degC', & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl,"S_RANGE", S_range, 'Initial salinity range', & + units='1e-3', default=2.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -195,7 +197,7 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CS call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, default=default_mld, do_not_log=.true.) call get_param(param_file, mdl, "DENSE_WATER_SILL_HEIGHT", sill_height, default=default_sill, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) call get_param(param_file, mdl, "S_RANGE", S_range, do_not_log=.true.) call get_param(param_file, mdl, "T_REF", T_ref, do_not_log=.true.) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index a0dee01b55..5136775918 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -207,17 +207,16 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file just_read = .false. ; if (present(just_read_params)) just_read = just_read_params - call get_param(param_file, mdl,"S_REF",S_ref,'Reference value for salinity', & - units='1e-3', fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Refernce value for temperature', & - units='C', fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference value for salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference value for temperature', & + units='degC', fail_if_missing=.not.just_read, do_not_log=just_read) - ! The default is to assume an increase by 2 for the salinity and a uniform - ! temperature + ! The default is to assume an increase by 2 ppt for the salinity and a uniform temperature. call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range.', & units='1e-3', default=2.0, do_not_log=just_read) call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) + units='degC', default=0.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From 613a82e6e59d35a8c162b5ccd42ec5ae32e68c44 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 11:55:45 -0400 Subject: [PATCH 059/256] +(*)Changed the default for MIN_SALINITY to 0 ppt Changed the default for MIN_SALINITY to 0 ppt from 0.01 ppt. This could change answers in cases where MIN_SALINITY is not set explicitly and the solution has salinities that get below 0.01 ppt. All answers are bitwise identical in the MOM6-examples test cases, but there are changes to the MOM_parameter_doc files. --- src/core/MOM.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 727a94e0a1..2ff06b85f0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1897,9 +1897,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "model may ask for more salt than is available and "//& "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 minimum value of salinity when BOUND_SALINITY=True.", & + units="PPT", default=0.0, 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 "//& From 8efe7c239ea33c5fa11545c4edabbbc7cdf79cfa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 6 Jun 2020 12:49:15 -0400 Subject: [PATCH 060/256] +Set the default for FLUXCONST to 0 m/day Set the default value of FLUXCONST to 0 m/day. Because there was previously no default and this was a mandatory parameter, the answers do not change, but there are changes to the MOM_parameter_doc files. --- .../MOM_surface_forcing_gfdl.F90 | 22 +++++++++---------- .../ice_solo_driver/MOM_surface_forcing.F90 | 7 +++--- .../ice_solo_driver/user_surface_forcing.F90 | 7 +++--- .../mct_driver/mom_surface_forcing_mct.F90 | 14 +++++------- .../mom_surface_forcing_nuopc.F90 | 14 +++++------- .../solo_driver/MESO_surface_forcing.F90 | 8 +++---- .../solo_driver/MOM_surface_forcing.F90 | 9 ++++---- .../solo_driver/Neverland_surface_forcing.F90 | 9 ++++---- .../solo_driver/user_surface_forcing.F90 | 9 +++----- src/user/BFB_surface_forcing.F90 | 7 +++--- src/user/dumbbell_surface_forcing.F90 | 7 +++--- 11 files changed, 48 insertions(+), 65 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index c9cb227697..7d2814da93 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1363,10 +1363,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restore_salt) then 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, fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + ! 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, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1374,8 +1375,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "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 "//& @@ -1411,10 +1410,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restore_temp) then 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, fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) + ! 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, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1422,8 +1422,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "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/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 4b58af618d..79bf924ca3 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -1110,10 +1110,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "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 "//& - "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/86400.0, fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_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/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index bb2580980b..64c4b4ce0a 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -328,10 +328,9 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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/86400.0, fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) 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 272e0ebd18..a42a8c3015 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1128,10 +1128,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_salt) then 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/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1174,10 +1173,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_temp) then 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 / 86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 5dcfecc4a3..3d49c66ce6 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1127,10 +1127,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_salt) then 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/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1173,10 +1172,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_temp) then 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/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 7d3689dc21..e2f0694b6c 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -252,11 +252,9 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T), & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & "The file with the SST toward which to restore in "//& diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index f7ef6d2c78..dc0226a993 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1683,11 +1683,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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/86400.0, & - fail_if_missing=.true., unscaled=flux_const_default) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & + unscaled=flux_const_default) if (CS%use_temperature) then call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index e624b8d7c2..28a8e84c25 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -257,11 +257,10 @@ subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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.) + 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.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%flux_const from m day-1 to m s-1. CS%flux_const = CS%flux_const / 86400.0 endif diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 2f071b7079..f5372e07d2 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -280,12 +280,9 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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 + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) endif end subroutine USER_surface_forcing_init diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 3debe9121a..d06262b7cf 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -230,10 +230,9 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 endif diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 4c582dd03e..4b5bf5a2fb 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -229,10 +229,9 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative 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.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 From 97740f754597b3217a2ef6bb9a97306aa4e77f19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Jun 2020 20:56:06 -0400 Subject: [PATCH 061/256] +(*)Changed the default for Z_INIT_REMAP_OLD_ALG Changed the default value of Z_INIT_REMAP_OLD_ALG to False. All answers in the MOM6-examples test suite are bitwise identical, but this could change answers in some test cases that use MOM_temp_salt_initialize_from_Z where Z_INIT_REMAP_OLD_ALG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c5e240d9dd..f07206704b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2107,7 +2107,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call get_param(PF, mdl, "Z_INIT_REMAP_OLD_ALG", remap_old_alg, & "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) + default=.false., do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false.) From 13df0912f3832609341d1bfbbd5d3cf8ddf1acb2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Jun 2020 20:57:44 -0400 Subject: [PATCH 062/256] +Changed the default for REPORT_UNUSED_PARAMS Changed the default for REPORT_UNUSED_PARAMS to true. All answers are bitwise identical, but there can be changes in model output and there will be changes to the MOM_parameter_doc.debugging files. --- src/framework/MOM_file_parser.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 8109890736..0cf049b61b 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -24,7 +24,7 @@ module MOM_file_parser !! TODO: Eliminate this parameter !>@{ Default values for parameters -logical, parameter :: report_unused_default = .false. +logical, parameter :: report_unused_default = .true. logical, parameter :: unused_params_fatal_default = .false. logical, parameter :: log_to_stdout_default = .false. logical, parameter :: complete_doc_default = .true. From da55f25a624dc0ac0e8fe8b325865215c3fcdaaf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Jun 2020 21:34:58 -0400 Subject: [PATCH 063/256] +(*)Changed default for FIX_UNSPLIT_DT_VISC_BUG to true Changed the default value of FIX_UNSPLIT_DT_VISC_BUG to true. Also added missing log_version to the three initialize_dyn routines. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in test cases using one of the unsplit time stepping schemes if FIX_UNSPLIT_DT_VISC_BUG is not set explicitly. There are changes to the MOM_parameter_doc files. --- src/core/MOM_continuity.F90 | 5 +++-- src/core/MOM_dynamics_split_RK2.F90 | 3 +++ src/core/MOM_dynamics_unsplit.F90 | 5 ++++- src/core/MOM_dynamics_unsplit_RK2.F90 | 7 +++++-- 4 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 9aaa6f92fc..cfb2b2e9fd 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -113,8 +113,9 @@ subroutine continuity_init(Time, G, GV, US, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Parameter file handles. type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_continuity" ! This module's name. character(len=20) :: tmpstr diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 5a20e60b04..276c3c330f 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -997,6 +997,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=48) :: thickness_units, flux_units, eta_rest_name real :: H_rescale ! A rescaling factor for thicknesses from the representation in ! a restart file to the internal representation in this run. @@ -1027,6 +1029,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%diag => diag + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "BE", CS%be, & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index d6a5186be3..6b9aa8e759 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -612,6 +612,8 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -629,11 +631,12 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%diag => diag + call log_version(param_file, mdl, version, "") 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.) + "unsplit_RK2.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e3ec48ff58..3bdeb0f21f 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -555,9 +555,11 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. - ! Local varaibles + ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -575,6 +577,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag CS%diag => diag + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& "of a 2nd-order Runga-Kutta baroclinic time stepping "//& @@ -595,7 +598,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag "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.) + "unsplit_RK2.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) From c13d0d5a98dc56ae6facfc569ca44af2d3542aa9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 7 Jun 2020 21:56:01 -0400 Subject: [PATCH 064/256] +(*)Changed default for GRID_ROTATION_ANGLE_BUGS Changed the default values of GRID_ROTATION_ANGLE_BUGS and USE_TRIPOLAR_GEOLONB_BUG to false. All answers in the MOM6-examples test suite are bitwise identical, but this will change answers in test cases with the SIS2 sea ice model if these parameters are not set explicitly. There are changes to the MOM_parameter_doc and SIS_parameter_doc files. --- src/initialization/MOM_grid_initialize.F90 | 2 +- src/initialization/MOM_shared_initialization.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 45c903f4ff..88130857c7 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -205,7 +205,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) call get_param(param_file, mdl, "USE_TRIPOLAR_GEOLONB_BUG", lon_bug, & "If true, use older code that incorrectly sets the longitude "//& "in some points along the tripolar fold to be off by 360 degrees.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) filename = trim(adjustl(inputdir)) // trim(adjustl(grid_file)) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 9311003863..51676fb54d 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -561,7 +561,7 @@ subroutine initialize_grid_rotation_angle(G, PF) "If true, use an older algorithm to calculate the sine and "//& "cosines needed rotate between grid-oriented directions and "//& "true north and east. Differences arise at the tripolar fold.", & - default=.True.) + default=.false.) if (use_bugs) then do j=G%jsc,G%jec ; do i=G%isc,G%iec From b1033f105376f03b76509e634e9314b1a05f4782 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 8 Jun 2020 21:30:32 +0000 Subject: [PATCH 065/256] Adds external_APIs/GFDL_ocean_BGC null modules - These have the same API (types, routines and arguments) as NOAA-GFDL/ocean_BGC but the routines/functions do nothing (no lines of instuctions) and the types have been stripped to the minimum that compiles. --- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 31 + .../external_APIs/GFDL_ocean_BGC/README.md | 6 + .../GFDL_ocean_BGC/fms_platform.h | 3 + .../GFDL_ocean_BGC/generic_tracer.F90 | 129 ++++ .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 572 ++++++++++++++++++ config_src/external_APIs/README.md | 10 + src/tracer/MOM_generic_tracer.F90 | 2 - src/tracer/MOM_tracer_flow_control.F90 | 37 -- 8 files changed, 751 insertions(+), 39 deletions(-) create mode 100644 config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 create mode 100644 config_src/external_APIs/GFDL_ocean_BGC/README.md create mode 100644 config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h create mode 100644 config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 create mode 100644 config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 create mode 100644 config_src/external_APIs/README.md diff --git a/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 new file mode 100644 index 0000000000..61b3ee1502 --- /dev/null +++ b/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -0,0 +1,31 @@ +module FMS_coupler_util + +use coupler_types_mod, only : coupler_2d_bc_type + +implicit none ; private + +public :: extract_coupler_values, set_coupler_values + +contains + +subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & + is, ie, js, je, conversion) + real, dimension(ilb:,jlb:),intent(out) :: array_out + integer, intent(in) :: ilb, jlb + type(coupler_2d_bc_type), intent(in) :: BC_struc + integer, intent(in) :: BC_index, BC_element + integer, optional, intent(in) :: is, ie, js, je + real, optional, intent(in) :: conversion +end subroutine extract_coupler_values + +subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& + is, ie, js, je, conversion) + real, dimension(ilb:,jlb:), intent(in) :: array_in + integer, intent(in) :: ilb, jlb + type(coupler_2d_bc_type), intent(inout) :: BC_struc + integer, intent(in) :: BC_index, BC_element + integer, optional, intent(in) :: is, ie, js, je + real, optional, intent(in) :: conversion +end subroutine set_coupler_values + +end module FMS_coupler_util diff --git a/config_src/external_APIs/GFDL_ocean_BGC/README.md b/config_src/external_APIs/GFDL_ocean_BGC/README.md new file mode 100644 index 0000000000..584e5aa16d --- /dev/null +++ b/config_src/external_APIs/GFDL_ocean_BGC/README.md @@ -0,0 +1,6 @@ +GFDL_ocean_BGC +============== + +These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. + +The modules in this directory do not do any computations. They simple reflect the APIs of the above package. diff --git a/config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h b/config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h new file mode 100644 index 0000000000..32faf4aa8c --- /dev/null +++ b/config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h @@ -0,0 +1,3 @@ +#define _ALLOCATED(arg) allocated(arg) +#define _ALLOCATABLE allocatable +#define _NULL diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 new file mode 100644 index 0000000000..aef080014e --- /dev/null +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 @@ -0,0 +1,129 @@ +module generic_tracer + + use time_manager_mod, only : time_type + use coupler_types_mod, only : coupler_2d_bc_type + + use g_tracer_utils, only : g_tracer_type, g_diag_type + + implicit none ; private + + public generic_tracer_register + public generic_tracer_init + public generic_tracer_register_diag + public generic_tracer_source + public generic_tracer_diag + public generic_tracer_update_from_bottom + public generic_tracer_coupler_get + public generic_tracer_coupler_set + public generic_tracer_coupler_zero + public generic_tracer_end + public generic_tracer_get_list + public do_generic_tracer + public generic_tracer_vertdiff_G + public generic_tracer_vertdiff_M + public generic_tracer_get_diag_list + public generic_tracer_coupler_accumulate + + logical :: do_generic_tracer = .false. + +contains + + subroutine generic_tracer_register + end subroutine generic_tracer_register + + subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) + type(time_type), intent(in) :: init_time + real, dimension(:,:,:),target, intent(in) :: grid_tmask + integer, dimension(:,:) , intent(in) :: grid_kmt + end subroutine generic_tracer_init + + subroutine generic_tracer_register_diag + end subroutine generic_tracer_register_diag + + subroutine generic_tracer_coupler_get(IOB_struc) + type(coupler_2d_bc_type), intent(in) :: IOB_struc + end subroutine generic_tracer_coupler_get + + subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) + type(coupler_2d_bc_type), intent(in) :: IOB_struc + real, intent(in) :: weight + type(time_type), optional,intent(in) :: model_time + end subroutine generic_tracer_coupler_accumulate + + subroutine generic_tracer_diag(ilb, jlb, tau, taup1, dtts, model_time, dzt, rho_dzt_tau, rho_dzt_taup1) + integer, intent(in) :: ilb + integer, intent(in) :: jlb + integer, intent(in) :: tau + integer, intent(in) :: taup1 + real, intent(in) :: dtts + type(time_type), intent(in) :: model_time + real, dimension(ilb:,jlb:,:), intent(in) :: dzt + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 + end subroutine generic_tracer_diag + + subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& + grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& + frunoff,grid_ht, current_wave_stress, sosga) + real, dimension(ilb:,jlb:,:), intent(in) :: Temp,Salt,rho_dzt,dzt + real, dimension(ilb:,jlb:), intent(in) :: hblt_depth + integer, intent(in) :: ilb,jlb,tau + real, intent(in) :: dtts + real, dimension(ilb:,jlb:), intent(in) :: grid_dat + type(time_type), intent(in) :: model_time + integer, intent(in) :: nbands + real, dimension(:), intent(in) :: max_wavelength_band + real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band + real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band + real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat + real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff + real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht + real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress + real, optional , intent(in) :: sosga ! global avg. sea surface salinity + end subroutine generic_tracer_source + + subroutine generic_tracer_update_from_bottom(dt, tau, model_time) + real, intent(in) :: dt + integer, intent(in) ::tau + type(time_type), intent(in) :: model_time + end subroutine generic_tracer_update_from_bottom + + subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) + real, dimension(:,:,:), intent(in) :: h_old, ea, eb + real, intent(in) :: dt, kg_m2_to_H, m_to_H + integer, intent(in) :: tau + end subroutine generic_tracer_vertdiff_G + + subroutine generic_tracer_vertdiff_M(dh, dhw, diff_cbt, dt, Rho_0,tau) + real, dimension(:,:,:), intent(in) :: dh, dhw, diff_cbt + real, intent(in) :: dt,Rho_0 + integer, intent(in) :: tau + end subroutine generic_tracer_vertdiff_M + + subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) + type(coupler_2d_bc_type), intent(inout) :: IOB_struc + integer, intent(in) :: ilb,jlb,tau + real, dimension(ilb:,jlb:), intent(in) :: ST,SS + real, dimension(ilb:,jlb:,:,:), intent(in) :: rho + real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt + real, optional, intent(in) :: sosga + type(time_type),optional, intent(in) :: model_time + end subroutine generic_tracer_coupler_set + + subroutine generic_tracer_coupler_zero(IOB_struc) + type(coupler_2d_bc_type), intent(inout) :: IOB_struc + end subroutine generic_tracer_coupler_zero + + subroutine generic_tracer_end + end subroutine generic_tracer_end + + subroutine generic_tracer_get_list(list) + type(g_tracer_type), pointer :: list + end subroutine generic_tracer_get_list + + subroutine generic_tracer_get_diag_list(list) + type(g_diag_type), pointer :: list + end subroutine generic_tracer_get_diag_list + +end module generic_tracer diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 new file mode 100644 index 0000000000..c6afc82bd2 --- /dev/null +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -0,0 +1,572 @@ +module g_tracer_utils +#include + + use coupler_types_mod, only: coupler_2d_bc_type + use time_manager_mod, only : time_type + + use field_manager_mod, only: fm_string_len + + use MOM_diag_mediator, only : register_diag_field_MOM=>register_diag_field + use MOM_diag_mediator, only : post_data_MOM=>post_data, post_data_1d_k + use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl + + +implicit none ; private + + type g_tracer_type +! ! Tracer concentration field in space (and time) +! ! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. + real, pointer, dimension(:,:,:,:) :: field => NULL() +! ! Tracer concentration in river runoff + real, _ALLOCATABLE, dimension(:,:) :: trunoff _NULL + logical :: requires_restart = .true. + character(len=fm_string_len) :: src_file, src_var_name, src_var_unit, src_var_gridspec + integer :: src_var_record + logical :: requires_src_info = .false. + real :: src_var_unit_conversion = 1.0 !This factor depends on the tracer. Ask Jasmin + real :: src_var_valid_min = 0.0 + end type g_tracer_type + + + type g_diag_type + integer :: dummy + end type g_diag_type + + type g_tracer_common + type(g_diag_ctrl) :: diag_CS + !Domain extents + integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk + end type g_tracer_common + + type(g_tracer_common), target, save :: g_tracer_com + + public :: g_tracer_type + public :: g_tracer_find + public :: g_tracer_add + public :: g_tracer_init + public :: g_tracer_flux_init + public :: g_tracer_column_int + public :: g_tracer_flux_at_depth + public :: g_tracer_add_param + public :: g_tracer_set_values + public :: g_tracer_get_values + public :: g_tracer_get_pointer + public :: g_tracer_get_common + public :: g_tracer_set_common + public :: g_tracer_set_csdiag + public :: g_tracer_set_files + public :: g_tracer_coupler_set + public :: g_tracer_coupler_get + public :: g_tracer_send_diag + public :: g_tracer_diag + public :: g_tracer_get_name + public :: g_tracer_get_alias + public :: g_tracer_get_next + public :: g_tracer_register_diag + public :: g_tracer_is_prog + public :: g_tracer_vertdiff_G + public :: g_tracer_vertdiff_M + public :: g_tracer_start_param_list + public :: g_tracer_end_param_list + public :: g_diag_type + public :: g_diag_field_add + public :: g_tracer_set_pointer + public :: g_tracer_print_info + public :: g_tracer_coupler_accumulate + public :: g_tracer_get_src_info + public :: g_register_diag_field + public :: g_send_data + + interface g_tracer_add_param + module procedure g_tracer_add_param_real + module procedure g_tracer_add_param_logical + module procedure g_tracer_add_param_integer + module procedure g_tracer_add_param_string + end interface + + interface g_tracer_set_pointer + module procedure g_tracer_set_pointer_3d + module procedure g_tracer_set_pointer_4d + end interface g_tracer_set_pointer + + interface g_send_data + module procedure g_send_data_0d + module procedure g_send_data_1d + module procedure g_send_data_2d + module procedure g_send_data_3d + end interface + + interface g_tracer_set_values + module procedure g_tracer_set_real + module procedure g_tracer_set_2D + module procedure g_tracer_set_3D + module procedure g_tracer_set_4D + end interface + + interface g_tracer_get_values + module procedure g_tracer_get_4D_val + module procedure g_tracer_get_3D_val + module procedure g_tracer_get_2D_val + module procedure g_tracer_get_real + module procedure g_tracer_get_string + end interface + + interface g_tracer_get_pointer + module procedure g_tracer_get_4D + module procedure g_tracer_get_3D + module procedure g_tracer_get_2D + end interface + +contains + + subroutine g_tracer_start_param_list(package_name) + character(len=fm_string_len), intent(in) :: package_name + character(len=fm_string_len), parameter :: sub_name = 'g_tracer_start_param_list' + character(len=fm_string_len) :: list_path + integer :: list_index + end subroutine g_tracer_start_param_list + + subroutine g_tracer_end_param_list(package_name) + character(len=fm_string_len) :: package_name + end subroutine g_tracer_end_param_list + + subroutine g_tracer_add_param_real(name, var, value) + character(len=*), intent(in) :: name + real, intent(in) :: value + real, intent(out) :: var + end subroutine g_tracer_add_param_real + + subroutine g_tracer_add_param_logical(name, var, value) + character(len=*), intent(in) :: name + logical, intent(in) :: value + logical, intent(out) :: var + end subroutine g_tracer_add_param_logical + + subroutine g_tracer_add_param_integer(name, var, value) + character(len=*), intent(in) :: name + integer, intent(in) :: value + integer, intent(out) :: var + end subroutine g_tracer_add_param_integer + + subroutine g_tracer_add_param_string(name, var, value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + character(len=*), intent(out) :: var + end subroutine g_tracer_add_param_string + + subroutine g_tracer_add(node_ptr, package, name, longname, units, prog, const_init_value,init_value,& + flux_gas, flux_gas_name, flux_runoff, flux_wetdep, flux_drydep, flux_gas_molwt, flux_gas_param, & + flux_param, flux_bottom, btm_reservoir, move_vertical, diff_vertical, sink_rate, flux_gas_restart_file, & + flux_gas_type, requires_src_info, standard_name,diag_name, diag_field_units,diag_field_scaling_factor, & + implementation) + type(g_tracer_type), pointer :: node_ptr + character(len=*), intent(in) :: package,name,longname,units + logical, intent(in) :: prog + real, intent(in), optional :: const_init_value + real, intent(in), optional :: init_value + real, intent(in), optional :: sink_rate + logical, intent(in), optional :: flux_gas + logical, intent(in), optional :: flux_runoff + logical, intent(in), optional :: flux_wetdep + logical, intent(in), optional :: flux_drydep + logical, intent(in), optional :: flux_bottom + logical, intent(in), optional :: btm_reservoir + logical, intent(in), optional :: move_vertical + logical, intent(in), optional :: diff_vertical + real, intent(in), optional :: flux_gas_molwt + real, dimension(:), intent(in), optional :: flux_gas_param + real, dimension(:), intent(in), optional :: flux_param + character(len=*), intent(in), optional :: flux_gas_name + character(len=*), intent(in), optional :: implementation + character(len=*), intent(in), optional :: flux_gas_type + character(len=*), intent(in), optional :: flux_gas_restart_file + logical, intent(in), optional :: requires_src_info + character(len=*), intent(in), optional :: standard_name + character(len=*), intent(in), optional :: diag_name + character(len=*), intent(in), optional :: diag_field_units + real, intent(in), optional :: diag_field_scaling_factor + end subroutine g_tracer_add + + function remap_bounds(ilb, jlb, klb, array) result(ptr) + real, dimension(:,:,:), pointer :: ptr + integer, intent(in) :: ilb + integer, intent(in) :: jlb + integer, intent(in) :: klb + real, dimension(ilb:,jlb:,klb:), target, intent(in) :: array + end function remap_bounds + + subroutine g_tracer_init(g_tracer) + type(g_tracer_type), pointer :: g_tracer + integer :: isc,iec,jsc,jec,isd,ied,jsd,jed, nk,ntau,axes(3) + end subroutine g_tracer_init + + subroutine g_tracer_flux_init(g_tracer) + type(g_tracer_type), pointer :: g_tracer + end subroutine g_tracer_flux_init + + subroutine g_tracer_register_diag(g_tracer) + type(g_tracer_type), pointer :: g_tracer + end subroutine g_tracer_register_diag + + subroutine g_tracer_coupler_set(g_tracer_list,IOB_struc,value) + type(g_tracer_type), pointer :: g_tracer_list,g_tracer + type(coupler_2d_bc_type), intent(inout) :: IOB_struc + real, optional :: value + end subroutine g_tracer_coupler_set + + subroutine g_tracer_coupler_get(g_tracer_list,IOB_struc, weight, model_time) + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + type(coupler_2d_bc_type), intent(in) :: IOB_struc + type(time_type), optional,intent(in) :: model_time + real, optional,intent(in) :: weight + end subroutine g_tracer_coupler_get + + subroutine g_tracer_coupler_accumulate(g_tracer_list,IOB_struc, weight, model_time) + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + type(coupler_2d_bc_type), intent(in) :: IOB_struc + real, intent(in) :: weight + type(time_type), optional, intent(in) :: model_time + end subroutine g_tracer_coupler_accumulate + + subroutine g_tracer_set_csdiag(diag_CS) + type(g_diag_ctrl), target,intent(in) :: diag_CS + g_tracer_com%diag_CS = diag_CS + end subroutine g_tracer_set_csdiag + + subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) + real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask + integer,dimension(isd:,jsd:),intent(in) :: grid_kmt + type(time_type), intent(in) :: init_time + end subroutine g_tracer_set_common + + subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& + axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) + integer, intent(out) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau + integer,optional, intent(out) :: axes(3) + type(time_type), optional, intent(out) :: init_time + real, optional, dimension(:,:,:),pointer :: grid_tmask + integer, optional, dimension(:,:), pointer :: grid_mask_coast + integer, optional, dimension(:,:), pointer :: grid_kmt + type(g_diag_ctrl), optional, pointer :: diag_CS + end subroutine g_tracer_get_common + + subroutine g_tracer_get_diagCS(diag_CS) + type(g_diag_ctrl), pointer :: diag_CS + end subroutine g_tracer_get_diagCS + + subroutine g_tracer_set_files(ice_restart_file,ocean_restart_file) + character(len=*), intent(in) :: ice_restart_file + character(len=*), intent(in) :: ocean_restart_file + end subroutine g_tracer_set_files + + subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + real, dimension(:,:,:,:), pointer :: array_ptr + end subroutine g_tracer_get_4D + + subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + real, dimension(:,:,:), pointer :: array_ptr + end subroutine g_tracer_get_3D + + subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + real, dimension(:,:), pointer :: array_ptr + end subroutine g_tracer_get_2D + + subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + real, dimension(isd:,jsd:,:,:), intent(out):: array + end subroutine g_tracer_get_4D_val + + subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + integer, optional, intent(in) :: ntau + logical, optional, intent(in) :: positive + real, dimension(isd:,jsd:,:), intent(out):: array + integer :: tau + character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' + end subroutine g_tracer_get_3D_val + + subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + real, dimension(isd:,jsd:), intent(out):: array + end subroutine g_tracer_get_2D_val + + subroutine g_tracer_get_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + real, intent(out):: value + end subroutine g_tracer_get_real + + subroutine g_tracer_get_string(g_tracer_list,name,member,string) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + character(len=fm_string_len), intent(out) :: string + character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_string' + end subroutine g_tracer_get_string + + subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + real, dimension(isd:,jsd:),intent(in) :: array + real, optional ,intent(in) :: weight + end subroutine g_tracer_set_2D + + subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + integer, optional, intent(in) :: ntau + real, dimension(isd:,jsd:,:), intent(in) :: array + end subroutine g_tracer_set_3D + + subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: isd,jsd + real, dimension(isd:,jsd:,:,:), intent(in) :: array + end subroutine g_tracer_set_4D + + subroutine g_tracer_set_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + real, intent(in) :: value + end subroutine g_tracer_set_real + + subroutine g_tracer_set_pointer_4D(g_tracer_list,name,member,array,ilb,jlb) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: ilb,jlb + real, dimension(ilb:,jlb:,:,:), target, intent(in) :: array + end subroutine g_tracer_set_pointer_4D + + subroutine g_tracer_set_pointer_3D(g_tracer_list,name,member,array,ilb,jlb) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: member + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer, intent(in) :: ilb,jlb + real, dimension(ilb:,jlb:,:), target, intent(in) :: array + end subroutine g_tracer_set_pointer_3D + + subroutine g_tracer_find(g_tracer,name) + character(len=*), intent(in) :: name + type(g_tracer_type), pointer :: g_tracer + end subroutine g_tracer_find + + subroutine g_tracer_column_int(depth, ilb, jlb, var, dzt, rho_dzt, rd, k_level, integral, caller) + real, intent(in) :: depth + integer, intent(in) :: ilb + integer, intent(in) :: jlb + real, dimension(ilb:,jlb:,:), intent(in) :: var + real, dimension(ilb:,jlb:,:), intent(in) :: dzt + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt + real, dimension(ilb:,jlb:,:), intent(inout) :: rd + integer, intent(inout) :: k_level + real, dimension(ilb:,jlb:), intent(out) :: integral + character(len=*), intent(in), optional :: caller + end subroutine g_tracer_column_int + + subroutine g_tracer_flux_at_depth(depth, ilb, jlb, var, dzt, k_level, frac, initialized, flux, caller) + real, intent(in) :: depth + integer, intent(in) :: ilb + integer, intent(in) :: jlb + real, dimension(ilb:,jlb:,:), intent(in) :: var + real, dimension(ilb:,jlb:,:), intent(in) :: dzt + integer, dimension(ilb:,jlb:), intent(inout) :: k_level + real, dimension(ilb:,jlb:), intent(inout) :: frac + logical, intent(inout) :: initialized + real, dimension(ilb:,jlb:), intent(out) :: flux + character(len=*), intent(in), optional :: caller + end subroutine g_tracer_flux_at_depth + + subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + type(time_type), intent(in) :: model_time + integer, intent(in) :: tau + end subroutine g_tracer_send_diag + + subroutine g_tracer_diag(g_tracer_list, ilb, jlb, rho_dzt_tau, rho_dzt_taup1, model_time, tau, taup1, dtts) + type(g_tracer_type), pointer :: g_tracer_list + integer, intent(in) :: ilb + integer, intent(in) :: jlb + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 + type(time_type), intent(in) :: model_time + integer, intent(in) :: tau + integer, intent(in) :: taup1 + real, intent(in) :: dtts + end subroutine g_tracer_diag + + subroutine g_tracer_traverse(g_tracer_list) + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + end subroutine g_tracer_traverse + + subroutine g_tracer_get_name(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer + character(len=*), intent(out) :: string + end subroutine g_tracer_get_name + + subroutine g_tracer_get_alias(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer + character(len=*), intent(out) :: string + end subroutine g_tracer_get_alias + + function g_tracer_is_prog(g_tracer) + logical :: g_tracer_is_prog + type(g_tracer_type), pointer :: g_tracer + end function g_tracer_is_prog + + subroutine g_tracer_get_next(g_tracer,g_tracer_next) + type(g_tracer_type), pointer :: g_tracer,g_tracer_next + end subroutine g_tracer_get_next + + subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) + type(g_tracer_type), pointer :: g_tracer + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old, ea, eb + real, intent(in) :: dt, kg_m2_to_H, m_to_H + integer, intent(in) :: tau + logical, intent(in), optional :: mom + end subroutine g_tracer_vertdiff_G + + subroutine g_tracer_vertdiff_M(g_tracer,dh, dhw, diff_cbt, dt, rho0,tau) + type(g_tracer_type), pointer :: g_tracer + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: dh, diff_cbt + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,0:), intent(in) :: dhw + real, intent(in) :: dt,rho0 + integer, intent(in) :: tau + end subroutine g_tracer_vertdiff_M + + subroutine g_diag_field_add(node_ptr, diag_id, package_name, name, axes, init_time, longname, units, & + missing_value, Z_diag, field_ptr, Zname, Zlongname, Zunits) + type(g_diag_type), pointer :: node_ptr + integer, intent(inout) :: diag_id + character(len=*), intent(in) :: package_name, name + integer, intent(in) :: axes(:) + type(time_type), intent(in) :: init_time + character(len=*), intent(in) :: longname, units + real, optional, intent(in) :: missing_value + integer, optional, intent(in) :: Z_diag + character(len=*), optional, intent(in) :: Zname, Zlongname, Zunits + real, optional, pointer :: field_ptr(:,:,:) + end subroutine g_diag_field_add + + subroutine g_tracer_print_info(g_tracer_list) + type(g_tracer_type), pointer :: g_tracer_list, g_tracer + integer :: num_prog,num_diag + end subroutine g_tracer_print_info + + subroutine g_tracer_get_src_info(g_tracer_list,name,src_file, src_var_name, src_var_unit, src_var_gridspec,& + src_var_record, src_var_valid_min, src_var_valid_max) + type(g_tracer_type), pointer :: g_tracer_list,g_tracer + character(len=*), intent(in) :: name + character(len=*), intent(out):: src_file, src_var_name, src_var_unit, src_var_gridspec + integer, intent(out):: src_var_record + real, intent(out):: src_var_valid_min, src_var_valid_max + end subroutine g_tracer_get_src_info + + function g_register_diag_field(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, v_cell_method, diag_CS) + integer :: g_register_diag_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type),intent(in) :: init_time !< Time at which a field is first available? + type(g_diag_ctrl),optional, pointer :: diag_CS + integer, optional, intent(in) :: axes(:) + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< no clue (not used in MOM?) + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. + !! If present, this overrides the default constructed from the default for + !! each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. + end function g_register_diag_field + + logical function g_send_data_0d(diag_field_id, field, time, err_msg, diag_CS) + integer, intent(in) :: diag_field_id + real, intent(in) :: field + type(time_type), intent(in), optional :: time + character(len=*), intent(out), optional :: err_msg + type(g_diag_ctrl),optional, pointer :: diag_CS + end function g_send_data_0d + + logical function g_send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg, diag_CS) + integer, intent(in) :: diag_field_id + real, dimension(:), intent(in) :: field + real, intent(in), optional :: weight + real, intent(in), dimension(:), optional :: rmask + type (time_type), intent(in), optional :: time + integer, intent(in), optional :: is_in, ie_in + logical, intent(in), dimension(:), optional :: mask + character(len=*), intent(out), optional :: err_msg + type(g_diag_ctrl),optional, pointer :: diag_CS + end function g_send_data_1d + + logical function g_send_data_2d(diag_field_id, field, time, is_in, js_in, & + & mask, rmask, ie_in, je_in, weight, err_msg, diag_CS) + integer, intent(in) :: diag_field_id + real, intent(in), dimension(:,:) :: field + real, intent(in), optional :: weight + type (time_type), intent(in), optional :: time + integer, intent(in), optional :: is_in, js_in, ie_in, je_in + logical, intent(in), dimension(:,:), optional :: mask + real, intent(in), dimension(:,:),optional :: rmask + character(len=*), intent(out), optional :: err_msg + type(g_diag_ctrl),optional, pointer :: diag_CS + end function g_send_data_2d + + logical function g_send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg, diag_CS) + integer, intent(in) :: diag_field_id + real, dimension(:,:,:), intent(in) :: field + real, intent(in), optional :: weight + type (time_type), intent(in), optional :: time + integer, intent(in), optional :: is_in, js_in, ks_in,ie_in,je_in, ke_in + logical, dimension(:,:,:), intent(in), optional :: mask + real, dimension(:,:,:), intent(in), optional :: rmask + character(len=*), intent(out), optional :: err_msg + type(g_diag_ctrl),optional, pointer :: diag_CS + end function g_send_data_3d + +end module g_tracer_utils diff --git a/config_src/external_APIs/README.md b/config_src/external_APIs/README.md new file mode 100644 index 0000000000..09af71e22d --- /dev/null +++ b/config_src/external_APIs/README.md @@ -0,0 +1,10 @@ +config_src/external_APIs +======================== + +Subdirectories in here provide null versions of external packages that +can be called by, or used with, MOM6 but that are not needed in all +configurations/executables. + +The APIs in these modules should be consistent with the actual external +package. To build with the actual external package include it in the +search path for your build system and remove the associated null version. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index b198db3e32..5cc1b5b363 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -4,7 +4,6 @@ module MOM_generic_tracer #include -#ifdef _USE_GENERIC_TRACER #include use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE @@ -820,7 +819,6 @@ subroutine end_MOM_generic_tracer(CS) endif end subroutine end_MOM_generic_tracer -#endif /* _USE_GENERIC_TRACER */ !---------------------------------------------------------------- ! Niki Zadeh ! diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index a9bf9a03d9..5e9f01c7be 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -51,12 +51,10 @@ module MOM_tracer_flow_control use dyed_obc_tracer, only : register_dyed_obc_tracer, initialize_dyed_obc_tracer use dyed_obc_tracer, only : dyed_obc_tracer_column_physics use dyed_obc_tracer, only : dyed_obc_tracer_end, dyed_obc_tracer_CS -#ifdef _USE_GENERIC_TRACER use MOM_generic_tracer, only : register_MOM_generic_tracer, initialize_MOM_generic_tracer use MOM_generic_tracer, only : MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state use MOM_generic_tracer, only : end_MOM_generic_tracer, MOM_generic_tracer_get, MOM_generic_flux_init use MOM_generic_tracer, only : MOM_generic_tracer_stock, MOM_generic_tracer_min_max, MOM_generic_tracer_CS -#endif use pseudo_salt_tracer, only : register_pseudo_salt_tracer, initialize_pseudo_salt_tracer use pseudo_salt_tracer, only : pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state use pseudo_salt_tracer, only : pseudo_salt_stock, pseudo_salt_tracer_end, pseudo_salt_tracer_CS @@ -96,9 +94,7 @@ module MOM_tracer_flow_control type(oil_tracer_CS), pointer :: oil_tracer_CSp => NULL() type(advection_test_tracer_CS), pointer :: advection_test_tracer_CSp => NULL() type(OCMIP2_CFC_CS), pointer :: OCMIP2_CFC_CSp => NULL() -#ifdef _USE_GENERIC_TRACER type(MOM_generic_tracer_CS), pointer :: MOM_generic_tracer_CSp => NULL() -#endif 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() @@ -132,13 +128,7 @@ subroutine call_tracer_flux_init(verbosity) if (use_OCMIP_CFCs) call flux_init_OCMIP2_CFC(verbosity=verbosity) if (use_MOM_generic_tracer) then -#ifdef _USE_GENERIC_TRACER call MOM_generic_flux_init(verbosity=verbosity) -#else - call MOM_error(FATAL, & - "call_tracer_flux_init: use_MOM_generic_tracer=.true. but MOM6 was "//& - "not compiled with _USE_GENERIC_TRACER") -#endif endif end subroutine call_tracer_flux_init @@ -217,12 +207,6 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "If true, use the dyed_obc_tracer tracer package.", & default=.false.) -#ifndef _USE_GENERIC_TRACER - if (CS%use_MOM_generic_tracer) call MOM_error(FATAL, & - "call_tracer_register: use_MOM_generic_tracer=.true. but MOM6 was "//& - "not compiled with _USE_GENERIC_TRACER") -#endif - ! Add other user-provided calls to register tracers for restarting here. Each ! tracer package registration call returns a logical false if it cannot be run ! for some reason. This then overrides the run-time selection from above. @@ -253,11 +237,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) if (CS%use_OCMIP2_CFC) CS%use_OCMIP2_CFC = & register_OCMIP2_CFC(HI, GV, param_file, CS%OCMIP2_CFC_CSp, & tr_Reg, restart_CS) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & tr_Reg, restart_CS) -#endif if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & tr_Reg, restart_CS) @@ -334,11 +316,9 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag if (CS%use_OCMIP2_CFC) & call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & sponge_CSp) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) -#endif if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & sponge_CSp, tv) @@ -359,7 +339,6 @@ subroutine get_chl_from_model(Chl_array, G, CS) type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) then call MOM_generic_tracer_get('chl','field',Chl_array, CS%MOM_generic_tracer_CSp) else @@ -367,12 +346,6 @@ subroutine get_chl_from_model(Chl_array, G, CS) "that is unable to provide a sensible model-based value.\n"// & "CS%use_MOM_generic_tracer is false and no other viable options are on.") endif -#else - call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & - "that is unable to provide a sensible model-based value.\n"// & - "_USE_GENERIC_TRACER is undefined and no other options "//& - "are currently viable.") -#endif end subroutine get_chl_from_model @@ -488,7 +461,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%OCMIP2_CFC_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) -#ifdef _USE_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 "//& @@ -498,7 +470,6 @@ 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) endif -#endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug, & @@ -544,7 +515,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_OCMIP2_CFC) & 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) 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 "//& @@ -552,7 +522,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, 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, & G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug) @@ -661,7 +630,6 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) then ns = MOM_generic_tracer_stock(h, values, G, GV, CS%MOM_generic_tracer_CSp, & names, units, stock_index) @@ -673,7 +641,6 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni G, CS%MOM_generic_tracer_CSp,names, units) endif -#endif if (CS%use_pseudo_salt_tracer) then ns = pseudo_salt_stock(h, values, G, GV, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) @@ -784,10 +751,8 @@ subroutine call_tracer_surface_state(sfc_state, h, G, CS) 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(sfc_state, h, G, CS%OCMIP2_CFC_CSp) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & call MOM_generic_tracer_surface_state(sfc_state, h, G, CS%MOM_generic_tracer_CSp) -#endif end subroutine call_tracer_surface_state @@ -805,9 +770,7 @@ subroutine tracer_flow_control_end(CS) if (CS%use_oil) call oil_tracer_end(CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) call advection_test_tracer_end(CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) call OCMIP2_CFC_end(CS%OCMIP2_CFC_CSp) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) call end_MOM_generic_tracer(CS%MOM_generic_tracer_CSp) -#endif if (CS%use_pseudo_salt_tracer) call pseudo_salt_tracer_end(CS%pseudo_salt_tracer_CSp) if (CS%use_boundary_impulse_tracer) call boundary_impulse_tracer_end(CS%boundary_impulse_tracer_CSp) if (CS%use_dyed_obc_tracer) call dyed_obc_tracer_end(CS%dyed_obc_tracer_CSp) From aefaadf8a9db27d4acb905cd9c6ceba78bccc24b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 8 Jun 2020 21:34:50 +0000 Subject: [PATCH 066/256] Fixes a assignment mismatch in MOM_generic_tracers - `dz_ml(i,j) = G%US%Z_to_m * Hml` does bad things when `Hml` is an array. I've added the missing `(i,j)`. --- src/tracer/MOM_generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index b198db3e32..3de6b4e0c6 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -487,7 +487,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dz_ml(:,:) = 0.0 do j=jsc,jec ; do i=isc,iec surface_field(i,j) = tv%S(i,j,1) - dz_ml(i,j) = G%US%Z_to_m * Hml + dz_ml(i,j) = G%US%Z_to_m * Hml(i,j) enddo ; enddo sosga = global_area_mean(surface_field, G) From e3d84c036e6708ac73a7d64a26f6722083987f4c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 8 Jun 2020 18:03:14 -0400 Subject: [PATCH 067/256] *Corrected two bugs impacting .testing test cases Corrected the velocities that are used in the call to set_viscous_ML with SPLIT=False and USE_RK2=True. This call had used the partially updated predictor velocities, which included other accelerations but not viscosity and which was missing a halo update, so it would not reproduce between symmetric and non-symmetric modes or across PE counts. This combination of parameters is not used in the MOM6-examples test suite, but it does change answers in some of the test cases in .testing. Also removed CORRECT_DENSITY=False from tc4/MOM_input, so that this test will not fail after this parameter is obsoleted. All answers and output in the MOM6-examples test suite are bitwise identical, but there are deliberate changes in the answers in the .testing test cases. --- .testing/tc4/MOM_input | 3 --- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 2b08e9bccb..4c17e6f70a 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -320,9 +320,6 @@ DTBT = 10.0 ! [s or nondim] default = -0.98 ! Parameterization of enhanced mixing due to convection via CVMix ! === module MOM_entrain_diffusive === -CORRECT_DENSITY = False ! [Boolean] default = True - ! If true, and USE_EOS is true, the layer densities are restored toward their - ! target values by the diapycnal mixing, as described in Hallberg (MWR, 2000). ! === module MOM_set_diffusivity === BBL_EFFIC = 0.0 ! [nondim] default = 0.2 diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e3ec48ff58..d6a4f9a274 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -340,7 +340,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) 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 set_viscous_ML(u_in, v_in, 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) From 8ee8a60e74a53efebde3b70c8625e23a1d06c652 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 8 Jun 2020 23:50:32 +0000 Subject: [PATCH 068/256] Include external_APIs in search path for .testing - New code was not being found by build. --- .testing/Makefile | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index d38189667b..b5086da31f 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -85,9 +85,11 @@ endif SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) -MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) +MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) \ + $(wildcard ../config_src/external_APIs/*/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ - $(wildcard build/target_codebase/config_src/solo_driver/*.F90) + $(wildcard build/target_codebase/config_src/solo_driver/*.F90) \ + $(wildcard build/target_codebase/config_src/external_APIs/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) #--- @@ -133,6 +135,7 @@ build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_SOURCE) cd $(@D) && $(LIST_PATHS) -l \ ../../$(TARGET_CODEBASE)/src \ ../../$(TARGET_CODEBASE)/config_src/solo_driver \ + ../../$(TARGET_CODEBASE)/config_src/external_APIs \ ../../$(TARGET_CODEBASE)/$(GRID_SRC) build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) @@ -140,6 +143,7 @@ build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) cd $(@D) && $(LIST_PATHS) -l \ ../../../src \ ../../../config_src/solo_driver \ + ../../../config_src/external_APIs \ ../../../$(GRID_SRC) # Target repository for regression tests From 570cf1926380878e3fb9187131dccb5525d601d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Jun 2020 05:45:17 -0400 Subject: [PATCH 069/256] Explicitly set parameters in tc MOM_input files Explicitly set parameters in the tc MOM_input files so that the answers in the regression test cases (perhaps apart from tc4) will not be changed by the changing defaults in the MOM6 code. --- .testing/tc0/MOM_input | 7 +++++++ .testing/tc1.a/MOM_tc_variant | 1 + .testing/tc1.b/MOM_tc_variant | 1 + .testing/tc1/MOM_input | 13 +++++++++++++ .testing/tc2/MOM_input | 11 +++++++++++ .testing/tc3/MOM_input | 9 +++++++++ .testing/tc4/MOM_input | 17 +++++++++++++++++ 7 files changed, 59 insertions(+) diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index 217b2d2c3d..be1cae0908 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -227,3 +227,10 @@ ENERGYSAVEDAYS = 1.0 DIAG_AS_CHKSUM = True DEBUG = True +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +USE_GM_WORK_BUG = True ! [Boolean] default = True +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant index 8032901a82..26407baf50 100644 --- a/.testing/tc1.a/MOM_tc_variant +++ b/.testing/tc1.a/MOM_tc_variant @@ -1 +1,2 @@ #override SPLIT=False +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant index 8d821691f3..173196f164 100644 --- a/.testing/tc1.b/MOM_tc_variant +++ b/.testing/tc1.b/MOM_tc_variant @@ -1,2 +1,3 @@ #override SPLIT=False #override USE_RK2=True +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 80fdd90860..68674f7a86 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -574,3 +574,16 @@ ENERGYSAVEDAYS = 0.125 ! [days] default = 3600.0 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +INTERPOLATE_RES_FN = True ! [Boolean] default = True +GILL_EQUATORIAL_LD = False ! [Boolean] default = False +USE_GM_WORK_BUG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +BULKML_CONV_MOMENTUM_BUG = True ! [Boolean] default = True +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 285ee79e4b..6678c00578 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -601,3 +601,14 @@ ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0 DIAG_AS_CHKSUM = True DEBUG = True USE_GM_WORK_BUG = False +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +USE_MLD_ITERATION = False ! [Boolean] default = False +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 4026665f11..9112898b4c 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -469,3 +469,12 @@ ENERGYSAVEDAYS = 3.0 ! [hours] default = 1.44E+04 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +OBC_RADIATION_MAX = 10.0 ! [nondim] default = 10.0 +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +USE_GM_WORK_BUG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 4c17e6f70a..04598a9dc9 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -407,3 +407,20 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 DIAG_AS_CHKSUM = True DEBUG = True + +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +INTERPOLATE_RES_FN = True ! [Boolean] default = True +GILL_EQUATORIAL_LD = False ! [Boolean] default = False +USE_GM_WORK_BUG = True ! [Boolean] default = True +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +USE_MLD_ITERATION = False ! [Boolean] default = False +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + From dd959b7992bf206125df23405a6c2f89defb2337 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 11 Jun 2020 10:31:33 -0400 Subject: [PATCH 070/256] Removing broken link to diag_table documentation. The exisiting documentation for diag_table is more than sufficient for existing MOM6 users. --- src/framework/_Diagnostics.dox | 1 - 1 file changed, 1 deletion(-) diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 44b3a6afe7..3db345ca1a 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -10,7 +10,6 @@ the former being diagnostics in the actual model coordinate space, and the latte \section diag_table The "diag_table" At run-time, diagnostics are controlled by the input file `diag_table` which is interpreted but the FMS package diag_manager. -The diag_table syntax is documented at http://data1.gfdl.noaa.gov/~nnz/MOM/mom5_pubrel_August2012/src/shared/diag_manager/diag_table.html. The diag_table file has three kinds of section: Title, File and Field. The title section is mandatory and always the first. There can be multiple file and field sections, typically either in pairs or grouped in to all files and all fields, From a43b480069b20a403e2f7527de40b3cbd265de41 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 01:11:05 +0000 Subject: [PATCH 071/256] Documented FMS_coupler_util API --- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 28 +++++++++++-------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 index 61b3ee1502..6e0d84da86 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -8,24 +8,28 @@ module FMS_coupler_util contains +!> Get element and index of a boundary condition subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & is, ie, js, je, conversion) - real, dimension(ilb:,jlb:),intent(out) :: array_out - integer, intent(in) :: ilb, jlb - type(coupler_2d_bc_type), intent(in) :: BC_struc - integer, intent(in) :: BC_index, BC_element - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion + real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values + integer, intent(in) :: ilb, jlb !< Lower bounds + type(coupler_2d_bc_type), intent(in) :: BC_struc !< A number that every element is multiplied by + integer, intent(in) :: BC_index !< The boundary condition number being extracted + integer, intent(in) :: BC_element !< The element of the boundary condition being extracted + integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by end subroutine extract_coupler_values +!> Set element and index of a boundary condition subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& is, ie, js, je, conversion) - real, dimension(ilb:,jlb:), intent(in) :: array_in - integer, intent(in) :: ilb, jlb - type(coupler_2d_bc_type), intent(inout) :: BC_struc - integer, intent(in) :: BC_index, BC_element - integer, optional, intent(in) :: is, ie, js, je - real, optional, intent(in) :: conversion + real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC + integer, intent(in) :: ilb, jlb !< Lower bounds + type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded + integer, intent(in) :: BC_index !< The boundary condition number being extracted + integer, intent(in) :: BC_element !< The element of the boundary condition being extracted + integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by end subroutine set_coupler_values end module FMS_coupler_util From 34ba51be2f7b89eff79983f2a6c86240800792ba Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 01:45:24 +0000 Subject: [PATCH 072/256] Attempted to document generic_tracer --- .../GFDL_ocean_BGC/generic_tracer.F90 | 130 +++++++++++------- 1 file changed, 81 insertions(+), 49 deletions(-) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 index aef080014e..3869a6a9dc 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 @@ -1,3 +1,4 @@ +!> A non-functioning template of the GFDL ocean BGC module generic_tracer use time_manager_mod, only : time_type @@ -24,106 +25,137 @@ module generic_tracer public generic_tracer_get_diag_list public generic_tracer_coupler_accumulate + !> Turn on generic tracers logical :: do_generic_tracer = .false. contains + !> Unknown subroutine generic_tracer_register end subroutine generic_tracer_register + !> Initialize generic tracers subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) - type(time_type), intent(in) :: init_time - real, dimension(:,:,:),target, intent(in) :: grid_tmask - integer, dimension(:,:) , intent(in) :: grid_kmt + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Domain boundaries and axes + type(time_type), intent(in) :: init_time !< Time + real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask + integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column end subroutine generic_tracer_init + !> Unknown subroutine generic_tracer_register_diag end subroutine generic_tracer_register_diag + !> Get coupler values subroutine generic_tracer_coupler_get(IOB_struc) - type(coupler_2d_bc_type), intent(in) :: IOB_struc + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure end subroutine generic_tracer_coupler_get + !> Unknown subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) - type(coupler_2d_bc_type), intent(in) :: IOB_struc - real, intent(in) :: weight - type(time_type), optional,intent(in) :: model_time + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure + real, intent(in) :: weight !< Unknown + type(time_type), optional,intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_accumulate + !> Do things which must be done after all transports and sources have been calculated subroutine generic_tracer_diag(ilb, jlb, tau, taup1, dtts, model_time, dzt, rho_dzt_tau, rho_dzt_taup1) - integer, intent(in) :: ilb - integer, intent(in) :: jlb - integer, intent(in) :: tau - integer, intent(in) :: taup1 - real, intent(in) :: dtts - type(time_type), intent(in) :: model_time - real, dimension(ilb:,jlb:,:), intent(in) :: dzt - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + integer, intent(in) :: taup1 !< Unknown + real, intent(in) :: dtts !< Unknown + type(time_type), intent(in) :: model_time !< Time + real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau !< Unknown + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 !< Unknown end subroutine generic_tracer_diag + !> Calls the corresponding generic_X_update_from_source routine for each package X subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& frunoff,grid_ht, current_wave_stress, sosga) - real, dimension(ilb:,jlb:,:), intent(in) :: Temp,Salt,rho_dzt,dzt - real, dimension(ilb:,jlb:), intent(in) :: hblt_depth - integer, intent(in) :: ilb,jlb,tau - real, intent(in) :: dtts - real, dimension(ilb:,jlb:), intent(in) :: grid_dat - type(time_type), intent(in) :: model_time - integer, intent(in) :: nbands + real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] + real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt + real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] + real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + real, intent(in) :: dtts !< Unknown + real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Unknown + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: nbands !< Unknown real, dimension(:), intent(in) :: max_wavelength_band - real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band - real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band - real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat - real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff - real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht - real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress + real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band !< Shortwave penetration + real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht !< Unknown + real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress !< Unknown real, optional , intent(in) :: sosga ! global avg. sea surface salinity end subroutine generic_tracer_source + !> Update the tracers from bottom fluxes subroutine generic_tracer_update_from_bottom(dt, tau, model_time) - real, intent(in) :: dt - integer, intent(in) ::tau - type(time_type), intent(in) :: model_time + real, intent(in) :: dt !< Time step increment + integer, intent(in) :: tau !< Time step index used for the concentration field + type(time_type), intent(in) :: model_time !< Time end subroutine generic_tracer_update_from_bottom + !> Vertically diffuse all generic tracers for GOLD ocean subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) - real, dimension(:,:,:), intent(in) :: h_old, ea, eb - real, intent(in) :: dt, kg_m2_to_H, m_to_H - integer, intent(in) :: tau + real, dimension(:,:,:), intent(in) :: h_old !< Unknown + real, dimension(:,:,:), intent(in) :: ea !< Unknown + real, dimension(:,:,:), intent(in) :: eb !< Unknown + real, intent(in) :: dt !< Unknown + real, intent(in) :: kg_m2_to_H !< Unknown + real, intent(in) :: m_to_H !< Unknown + integer, intent(in) :: tau !< Unknown end subroutine generic_tracer_vertdiff_G + !> Set the coupler values for each generic tracer subroutine generic_tracer_vertdiff_M(dh, dhw, diff_cbt, dt, Rho_0,tau) - real, dimension(:,:,:), intent(in) :: dh, dhw, diff_cbt - real, intent(in) :: dt,Rho_0 - integer, intent(in) :: tau + real, dimension(:,:,:), intent(in) :: dh !< Unknown + real, dimension(:,:,:), intent(in) :: dhw !< Unknown + real, dimension(:,:,:), intent(in) :: diff_cbt !< Unknown + real, intent(in) :: dt !< Unknown + real, intent(in) :: Rho_0 !< Unknown + integer, intent(in) :: tau !< Unknown end subroutine generic_tracer_vertdiff_M + !> Set the coupler values for each generic tracer subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) - type(coupler_2d_bc_type), intent(inout) :: IOB_struc - integer, intent(in) :: ilb,jlb,tau - real, dimension(ilb:,jlb:), intent(in) :: ST,SS - real, dimension(ilb:,jlb:,:,:), intent(in) :: rho - real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt - real, optional, intent(in) :: sosga - type(time_type),optional, intent(in) :: model_time + type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + real, dimension(ilb:,jlb:), intent(in) :: ST !< Sea surface temperature [deg C] + real, dimension(ilb:,jlb:), intent(in) :: SS !< Sea surface salinity [psu] + real, dimension(ilb:,jlb:,:,:), intent(in) :: rho !< Ocean density [kg m-3] + real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt !< Layer thickness [m] + real, optional, intent(in) :: sosga !< Unknown + type(time_type),optional, intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_set + !> Zero out the coupler values for each tracer subroutine generic_tracer_coupler_zero(IOB_struc) - type(coupler_2d_bc_type), intent(inout) :: IOB_struc + type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure end subroutine generic_tracer_coupler_zero + !> End this module by calling the corresponding generic_X_end for each package X subroutine generic_tracer_end end subroutine generic_tracer_end + !> Get a pointer to the head of the generic tracers list subroutine generic_tracer_get_list(list) - type(g_tracer_type), pointer :: list + type(g_tracer_type), pointer :: list !< Pointer to head of the linked list end subroutine generic_tracer_get_list + !> Unknown subroutine generic_tracer_get_diag_list(list) - type(g_diag_type), pointer :: list + type(g_diag_type), pointer :: list !< Pointer to head of the linked list end subroutine generic_tracer_get_diag_list end module generic_tracer From ab9398ea0327033843f64a4e65b571b197feb6fa Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 21:49:04 +0000 Subject: [PATCH 073/256] Commented out unused interfaces in generic_tracer --- .../GFDL_ocean_BGC/generic_tracer.F90 | 60 +++++++++---------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 index 3869a6a9dc..19b7532adc 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 @@ -12,21 +12,21 @@ module generic_tracer public generic_tracer_init public generic_tracer_register_diag public generic_tracer_source - public generic_tracer_diag +! public generic_tracer_diag public generic_tracer_update_from_bottom public generic_tracer_coupler_get public generic_tracer_coupler_set - public generic_tracer_coupler_zero +! public generic_tracer_coupler_zero public generic_tracer_end public generic_tracer_get_list public do_generic_tracer public generic_tracer_vertdiff_G - public generic_tracer_vertdiff_M +! public generic_tracer_vertdiff_M public generic_tracer_get_diag_list public generic_tracer_coupler_accumulate - !> Turn on generic tracers - logical :: do_generic_tracer = .false. + !> Turn on generic tracers (note dangerous use of module data) + logical :: do_generic_tracer = .true. contains @@ -58,18 +58,18 @@ subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) type(time_type), optional,intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_accumulate - !> Do things which must be done after all transports and sources have been calculated - subroutine generic_tracer_diag(ilb, jlb, tau, taup1, dtts, model_time, dzt, rho_dzt_tau, rho_dzt_taup1) - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain - integer, intent(in) :: tau !< Time step index of %field - integer, intent(in) :: taup1 !< Unknown - real, intent(in) :: dtts !< Unknown - type(time_type), intent(in) :: model_time !< Time - real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau !< Unknown - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 !< Unknown - end subroutine generic_tracer_diag +! !> Do things which must be done after all transports and sources have been calculated +! subroutine generic_tracer_diag(ilb, jlb, tau, taup1, dtts, model_time, dzt, rho_dzt_tau, rho_dzt_taup1) +! integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain +! integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain +! integer, intent(in) :: tau !< Time step index of %field +! integer, intent(in) :: taup1 !< Unknown +! real, intent(in) :: dtts !< Unknown +! type(time_type), intent(in) :: model_time !< Time +! real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] +! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau !< Unknown +! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 !< Unknown +! end subroutine generic_tracer_diag !> Calls the corresponding generic_X_update_from_source routine for each package X subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& @@ -115,15 +115,15 @@ subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) integer, intent(in) :: tau !< Unknown end subroutine generic_tracer_vertdiff_G - !> Set the coupler values for each generic tracer - subroutine generic_tracer_vertdiff_M(dh, dhw, diff_cbt, dt, Rho_0,tau) - real, dimension(:,:,:), intent(in) :: dh !< Unknown - real, dimension(:,:,:), intent(in) :: dhw !< Unknown - real, dimension(:,:,:), intent(in) :: diff_cbt !< Unknown - real, intent(in) :: dt !< Unknown - real, intent(in) :: Rho_0 !< Unknown - integer, intent(in) :: tau !< Unknown - end subroutine generic_tracer_vertdiff_M +! !> Set the coupler values for each generic tracer +! subroutine generic_tracer_vertdiff_M(dh, dhw, diff_cbt, dt, Rho_0,tau) +! real, dimension(:,:,:), intent(in) :: dh !< Unknown +! real, dimension(:,:,:), intent(in) :: dhw !< Unknown +! real, dimension(:,:,:), intent(in) :: diff_cbt !< Unknown +! real, intent(in) :: dt !< Unknown +! real, intent(in) :: Rho_0 !< Unknown +! integer, intent(in) :: tau !< Unknown +! end subroutine generic_tracer_vertdiff_M !> Set the coupler values for each generic tracer subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) @@ -139,10 +139,10 @@ subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sos type(time_type),optional, intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_set - !> Zero out the coupler values for each tracer - subroutine generic_tracer_coupler_zero(IOB_struc) - type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure - end subroutine generic_tracer_coupler_zero +! !> Zero out the coupler values for each tracer +! subroutine generic_tracer_coupler_zero(IOB_struc) +! type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure +! end subroutine generic_tracer_coupler_zero !> End this module by calling the corresponding generic_X_end for each package X subroutine generic_tracer_end From 6a06544f1b5764cd6221aef15b50d4c6dde17ace Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 21:53:50 +0000 Subject: [PATCH 074/256] Attempted to document generic_tracer_utils - Documented some APIs that aren't used and then commented them out. ! --- .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 992 ++++++++++-------- 1 file changed, 546 insertions(+), 446 deletions(-) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 index c6afc82bd2..185da0052e 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -1,572 +1,672 @@ +!> g_tracer_utils module consists of core utility subroutines to be used by +!! all generic tracer modules. These include the lowest level functions +!! for adding, allocating memory, and record keeping of individual generic +!! tracers irrespective of their physical/chemical nature. module g_tracer_utils #include use coupler_types_mod, only: coupler_2d_bc_type use time_manager_mod, only : time_type - use field_manager_mod, only: fm_string_len - - use MOM_diag_mediator, only : register_diag_field_MOM=>register_diag_field - use MOM_diag_mediator, only : post_data_MOM=>post_data, post_data_1d_k use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl - implicit none ; private + !> Each generic tracer node is an instant of a FORTRAN type with the following member variables. + !! These member fields are supposed to uniquely define an individual tracer. + !! One such type shall be instantiated for EACH individual tracer. type g_tracer_type -! ! Tracer concentration field in space (and time) -! ! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. + !> Tracer concentration field in space (and time) + !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. real, pointer, dimension(:,:,:,:) :: field => NULL() -! ! Tracer concentration in river runoff - real, _ALLOCATABLE, dimension(:,:) :: trunoff _NULL - logical :: requires_restart = .true. + !> Tracer concentration in river runoff + real, _ALLOCATABLE, dimension(:,:) :: trunoff _NULL + logical :: requires_restart = .true. !< Unknown + !> Tracer source: filename, type, var name, units, record, gridfile character(len=fm_string_len) :: src_file, src_var_name, src_var_unit, src_var_gridspec - integer :: src_var_record - logical :: requires_src_info = .false. - real :: src_var_unit_conversion = 1.0 !This factor depends on the tracer. Ask Jasmin - real :: src_var_valid_min = 0.0 + integer :: src_var_record !< Unknown + logical :: requires_src_info = .false. !< Unknown + real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin + real :: src_var_valid_min = 0.0 !< Unknown end type g_tracer_type - + !> Unknown type g_diag_type - integer :: dummy + integer :: dummy !< A dummy member, not part of the API end type g_diag_type + !> The following type fields are common to ALL generic tracers and hence has to be instantiated only once type g_tracer_common - type(g_diag_ctrl) :: diag_CS - !Domain extents - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk +! type(g_diag_ctrl) :: diag_CS !< Unknown + !> Domain extents + integer :: isd,jsd end type g_tracer_common + !> Unknown dangerous module data! type(g_tracer_common), target, save :: g_tracer_com public :: g_tracer_type - public :: g_tracer_find - public :: g_tracer_add - public :: g_tracer_init +! public :: g_tracer_find +! public :: g_tracer_add +! public :: g_tracer_init public :: g_tracer_flux_init - public :: g_tracer_column_int - public :: g_tracer_flux_at_depth - public :: g_tracer_add_param +! public :: g_tracer_column_int +! public :: g_tracer_flux_at_depth +! public :: g_tracer_add_param public :: g_tracer_set_values public :: g_tracer_get_values public :: g_tracer_get_pointer public :: g_tracer_get_common public :: g_tracer_set_common public :: g_tracer_set_csdiag - public :: g_tracer_set_files - public :: g_tracer_coupler_set - public :: g_tracer_coupler_get +! public :: g_tracer_set_files +! public :: g_tracer_coupler_set +! public :: g_tracer_coupler_get public :: g_tracer_send_diag - public :: g_tracer_diag +! public :: g_tracer_diag public :: g_tracer_get_name public :: g_tracer_get_alias public :: g_tracer_get_next - public :: g_tracer_register_diag +! public :: g_tracer_register_diag public :: g_tracer_is_prog - public :: g_tracer_vertdiff_G - public :: g_tracer_vertdiff_M - public :: g_tracer_start_param_list - public :: g_tracer_end_param_list +! public :: g_tracer_vertdiff_G +! public :: g_tracer_vertdiff_M +! public :: g_tracer_start_param_list +! public :: g_tracer_end_param_list public :: g_diag_type - public :: g_diag_field_add - public :: g_tracer_set_pointer - public :: g_tracer_print_info - public :: g_tracer_coupler_accumulate - public :: g_tracer_get_src_info - public :: g_register_diag_field - public :: g_send_data - - interface g_tracer_add_param - module procedure g_tracer_add_param_real - module procedure g_tracer_add_param_logical - module procedure g_tracer_add_param_integer - module procedure g_tracer_add_param_string - end interface - - interface g_tracer_set_pointer - module procedure g_tracer_set_pointer_3d - module procedure g_tracer_set_pointer_4d - end interface g_tracer_set_pointer - - interface g_send_data - module procedure g_send_data_0d - module procedure g_send_data_1d - module procedure g_send_data_2d - module procedure g_send_data_3d - end interface - +! public :: g_diag_field_add +! public :: g_tracer_set_pointer +! public :: g_tracer_print_info +! public :: g_tracer_coupler_accumulate +! public :: g_tracer_get_src_info +! public :: g_register_diag_field +! public :: g_send_data + +! !> Add a new parameter for the generic tracer package +! !! +! !! This subroutine is used to add a new parameter by the calling tracer package. +! !! It provides a mechanism for parameter overwrite through the field_table. +! !! For each tracer package there is a field called namelists and there +! !! the parameters can be modified from their value set by this method. +! !! E.g., we may have the following in the field_table +! !! +! !! "namelists","ocean_mod","generic_topaz" +! !! init = t +! !! / +! !! +! !! This will overwrite the parameter topaz%init to be .true. at the run time +! !! even though generic_topaz package had in the code +! !! `call g_tracer_add_param('init', topaz%init, .false. )` +! !! +! !! For the parameters overwrite mechanism to work all calls +! !! for adding new parameters (refer to description for subroutine g_tracer_add_param) +! !! should happen between a `call g_tracer_start_param_list(package_name)` +! !! and a `call g_tracer_end_param_list(package_name)` +! interface g_tracer_add_param +! module procedure g_tracer_add_param_real +! module procedure g_tracer_add_param_logical +! module procedure g_tracer_add_param_integer +! module procedure g_tracer_add_param_string +! end interface + +! !> Unknown +! interface g_tracer_set_pointer +! module procedure g_tracer_set_pointer_3d +! module procedure g_tracer_set_pointer_4d +! end interface g_tracer_set_pointer + +! !> Unknown +! interface g_send_data +! module procedure g_send_data_0d +! module procedure g_send_data_1d +! module procedure g_send_data_2d +! module procedure g_send_data_3d +! end interface + + !> Set the values of various (array) members of the tracer node g_tracer_type + !! + !! This function is overloaded to set the values of the following member variables interface g_tracer_set_values - module procedure g_tracer_set_real - module procedure g_tracer_set_2D - module procedure g_tracer_set_3D - module procedure g_tracer_set_4D + module procedure g_tracer_set_real + module procedure g_tracer_set_2D + module procedure g_tracer_set_3D + module procedure g_tracer_set_4D end interface + !> Reverse of interface g_tracer_set_values for getting the tracer member arrays in the argument value + !! + !! This means "get the values of array %field_name for tracer tracer_name and put them in argument array_out" interface g_tracer_get_values - module procedure g_tracer_get_4D_val - module procedure g_tracer_get_3D_val - module procedure g_tracer_get_2D_val - module procedure g_tracer_get_real - module procedure g_tracer_get_string + module procedure g_tracer_get_4D_val + module procedure g_tracer_get_3D_val + module procedure g_tracer_get_2D_val + module procedure g_tracer_get_real + module procedure g_tracer_get_string end interface + !> Return the pointer to the requested field of a particular tracer + !! + !! This means "get the pointer of array %field_name for tracer tracer_name in argument array_ptr" interface g_tracer_get_pointer - module procedure g_tracer_get_4D - module procedure g_tracer_get_3D - module procedure g_tracer_get_2D + module procedure g_tracer_get_4D + module procedure g_tracer_get_3D + module procedure g_tracer_get_2D end interface contains - subroutine g_tracer_start_param_list(package_name) - character(len=fm_string_len), intent(in) :: package_name - character(len=fm_string_len), parameter :: sub_name = 'g_tracer_start_param_list' - character(len=fm_string_len) :: list_path - integer :: list_index - end subroutine g_tracer_start_param_list - - subroutine g_tracer_end_param_list(package_name) - character(len=fm_string_len) :: package_name - end subroutine g_tracer_end_param_list - - subroutine g_tracer_add_param_real(name, var, value) - character(len=*), intent(in) :: name - real, intent(in) :: value - real, intent(out) :: var - end subroutine g_tracer_add_param_real - - subroutine g_tracer_add_param_logical(name, var, value) - character(len=*), intent(in) :: name - logical, intent(in) :: value - logical, intent(out) :: var - end subroutine g_tracer_add_param_logical - - subroutine g_tracer_add_param_integer(name, var, value) - character(len=*), intent(in) :: name - integer, intent(in) :: value - integer, intent(out) :: var - end subroutine g_tracer_add_param_integer - - subroutine g_tracer_add_param_string(name, var, value) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: value - character(len=*), intent(out) :: var - end subroutine g_tracer_add_param_string - - subroutine g_tracer_add(node_ptr, package, name, longname, units, prog, const_init_value,init_value,& - flux_gas, flux_gas_name, flux_runoff, flux_wetdep, flux_drydep, flux_gas_molwt, flux_gas_param, & - flux_param, flux_bottom, btm_reservoir, move_vertical, diff_vertical, sink_rate, flux_gas_restart_file, & - flux_gas_type, requires_src_info, standard_name,diag_name, diag_field_units,diag_field_scaling_factor, & - implementation) - type(g_tracer_type), pointer :: node_ptr - character(len=*), intent(in) :: package,name,longname,units - logical, intent(in) :: prog - real, intent(in), optional :: const_init_value - real, intent(in), optional :: init_value - real, intent(in), optional :: sink_rate - logical, intent(in), optional :: flux_gas - logical, intent(in), optional :: flux_runoff - logical, intent(in), optional :: flux_wetdep - logical, intent(in), optional :: flux_drydep - logical, intent(in), optional :: flux_bottom - logical, intent(in), optional :: btm_reservoir - logical, intent(in), optional :: move_vertical - logical, intent(in), optional :: diff_vertical - real, intent(in), optional :: flux_gas_molwt - real, dimension(:), intent(in), optional :: flux_gas_param - real, dimension(:), intent(in), optional :: flux_param - character(len=*), intent(in), optional :: flux_gas_name - character(len=*), intent(in), optional :: implementation - character(len=*), intent(in), optional :: flux_gas_type - character(len=*), intent(in), optional :: flux_gas_restart_file - logical, intent(in), optional :: requires_src_info - character(len=*), intent(in), optional :: standard_name - character(len=*), intent(in), optional :: diag_name - character(len=*), intent(in), optional :: diag_field_units - real, intent(in), optional :: diag_field_scaling_factor - end subroutine g_tracer_add - - function remap_bounds(ilb, jlb, klb, array) result(ptr) - real, dimension(:,:,:), pointer :: ptr - integer, intent(in) :: ilb - integer, intent(in) :: jlb - integer, intent(in) :: klb - real, dimension(ilb:,jlb:,klb:), target, intent(in) :: array - end function remap_bounds - - subroutine g_tracer_init(g_tracer) - type(g_tracer_type), pointer :: g_tracer - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed, nk,ntau,axes(3) - end subroutine g_tracer_init - +! !> Mark the start of adding new parameters for a package +! !! For the parameters override mechanism to work all calls +! !! for adding new parameters (refer to description for subroutine g_tracer_add_param) +! !! should happen between a `call g_tracer_start_param_list(package_name)` +! !! and a `call g_tracer_end_param_list(package_name)` +! subroutine g_tracer_start_param_list(package_name) +! !> Name of the generic tracer package that is adding the parameters (e.g., "generic_cfc") +! character(len=fm_string_len), intent(in) :: package_name +! end subroutine g_tracer_start_param_list + +! !> Mark the start of adding new parameters for a package +! subroutine g_tracer_end_param_list(package_name) +! !> Name of the generic tracer package that is adding the parameters (e.g., "generic_cfc") +! character(len=fm_string_len) :: package_name +! end subroutine g_tracer_end_param_list + +! !> Overload interface g_tracer_add_param for real parameter +! subroutine g_tracer_add_param_real(name, var, value) +! character(len=*), intent(in) :: name !< Unknown +! real, intent(in) :: value !< Unknown +! real, intent(out) :: var !< Unknown +! end subroutine g_tracer_add_param_real + +! !> Overload interface g_tracer_add_param for logical parameter +! subroutine g_tracer_add_param_logical(name, var, value) +! character(len=*), intent(in) :: name !< Unknown +! logical, intent(in) :: value !< Unknown +! logical, intent(out) :: var !< Unknown +! end subroutine g_tracer_add_param_logical + +! !> Overload interface g_tracer_add_param for integer parameter +! subroutine g_tracer_add_param_integer(name, var, value) +! character(len=*), intent(in) :: name !< Unknown +! integer, intent(in) :: value !< Unknown +! integer, intent(out) :: var !< Unknown +! end subroutine g_tracer_add_param_integer + +! !> Overload interface g_tracer_add_param for string parameter +! subroutine g_tracer_add_param_string(name, var, value) +! character(len=*), intent(in) :: name !< Unknown +! character(len=*), intent(in) :: value !< Unknown +! character(len=*), intent(out) :: var !< Unknown +! end subroutine g_tracer_add_param_string + +! !> Add a new tracer (node) at the top of the list of generic tracers +! !! This subroutine call adds an individual new tracer to the growing list of generic tracers. +! !! It then allocates all the necessary arrays for using this tracer in the Ocean model that requested it. +! !! The information passed into this subroutine should be enough to fully describe the individual tracer +! subroutine g_tracer_add(node_ptr, package, name, longname, units, prog, const_init_value,init_value,& +! flux_gas, flux_gas_name, flux_runoff, flux_wetdep, flux_drydep, flux_gas_molwt, flux_gas_param, & +! flux_param, flux_bottom, btm_reservoir, move_vertical, diff_vertical, sink_rate, flux_gas_restart_file, & +! flux_gas_type, requires_src_info, standard_name,diag_name, diag_field_units,diag_field_scaling_factor, & +! implementation) +! !> Pointer to the head node of the tracer list. This is also going to be the pointer to the node being added after the call +! type(g_tracer_type), pointer :: node_ptr +! character(len=*), intent(in) :: package !< Name of tracer package adding this node +! character(len=*), intent(in) :: name !< Name of this tracer +! character(len=*), intent(in) :: longname !< Descriptive name of this tracer +! character(len=*), intent(in) :: units !< Concentration units (units of array %field) +! logical, intent(in) :: prog !< .true. for prognastic , .false. for diagnostic tracer +! real, intent(in), optional :: const_init_value !< Initial value of concenteration if constant +! real, intent(in), optional :: init_value !< Unknown +! real, intent(in), optional :: sink_rate !< Sinking rate if non-zero +! logical, intent(in), optional :: flux_gas !< .true. if there is gas flux exchange with atmos +! logical, intent(in), optional :: flux_runoff !< .true. if there is runoff flux +! logical, intent(in), optional :: flux_wetdep !< .true. if there is wetdep flux +! logical, intent(in), optional :: flux_drydep !< .true. if there is drydep flux +! logical, intent(in), optional :: flux_bottom !< .true. if there is bottom flux +! logical, intent(in), optional :: btm_reservoir !< .true. if there is bottom reservoir +! logical, intent(in), optional :: move_vertical !< .true. if there is active vertical movement +! logical, intent(in), optional :: diff_vertical !< Unknown +! real, intent(in), optional :: flux_gas_molwt !< Unknown +! real, dimension(:), intent(in), optional :: flux_gas_param !< Array of parameters for gas flux (refer to documentation for subroutine aof_set_coupler_flux() ) +! real, dimension(:), intent(in), optional :: flux_param !< Array of parameters for non-gas flux (refer to documentation for subroutine aof_set_coupler_flux() ) +! character(len=*), intent(in), optional :: flux_gas_name !< Name of the atmospheric tracer to exchange flux with (if flux_gas=.true.) +! character(len=*), intent(in), optional :: implementation !< Unknown +! character(len=*), intent(in), optional :: flux_gas_type !< Unknown +! character(len=*), intent(in), optional :: flux_gas_restart_file !< Unknown +! logical, intent(in), optional :: requires_src_info !< Unknown +! character(len=*), intent(in), optional :: standard_name !< Unknown +! character(len=*), intent(in), optional :: diag_name !< Unknown +! character(len=*), intent(in), optional :: diag_field_units !< Unknown +! real, intent(in), optional :: diag_field_scaling_factor !< Unknown +! end subroutine g_tracer_add + +! !> Unknown +! subroutine g_tracer_init(g_tracer) +! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node +! end subroutine g_tracer_init + + !> Unknown subroutine g_tracer_flux_init(g_tracer) - type(g_tracer_type), pointer :: g_tracer + type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node end subroutine g_tracer_flux_init - subroutine g_tracer_register_diag(g_tracer) - type(g_tracer_type), pointer :: g_tracer - end subroutine g_tracer_register_diag - - subroutine g_tracer_coupler_set(g_tracer_list,IOB_struc,value) - type(g_tracer_type), pointer :: g_tracer_list,g_tracer - type(coupler_2d_bc_type), intent(inout) :: IOB_struc - real, optional :: value - end subroutine g_tracer_coupler_set - - subroutine g_tracer_coupler_get(g_tracer_list,IOB_struc, weight, model_time) - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - type(coupler_2d_bc_type), intent(in) :: IOB_struc - type(time_type), optional,intent(in) :: model_time - real, optional,intent(in) :: weight - end subroutine g_tracer_coupler_get - - subroutine g_tracer_coupler_accumulate(g_tracer_list,IOB_struc, weight, model_time) - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - type(coupler_2d_bc_type), intent(in) :: IOB_struc - real, intent(in) :: weight - type(time_type), optional, intent(in) :: model_time - end subroutine g_tracer_coupler_accumulate - +! !> Diag-register all the internal fields that were _ALLOCATED for a tracer +! !! +! !! Use diag_manager register_diag_field for each of the field arrays that were _ALLOCATED for a tracer node. +! !! These include %field, %tendency, %stf, %stf_gas, %deltap, %kw, %btf, %trunoff, %alpha, %csurf, %sc_no, %btm_reservoir. +! subroutine g_tracer_register_diag(g_tracer) +! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node +! end subroutine g_tracer_register_diag + +! !> Set coupler values only for tracers that have _ALLOCATED %alpha, %csurf and %sc_no +! !! +! !! Use coupler_util subroutine set_coupler_values() to set the coupler values +! !! for fluxes to be exchanged with Ice for the requested fluxes. +! !! NOTE: +! !! This is a collective subroutine and will transverse the list of generic tracers and +! !! set the coupler values for each tracer node accordingly. +! subroutine g_tracer_coupler_set(g_tracer_list,IOB_struc,value) +! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list +! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node +! type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< The coupler flux IOB structure +! real, optional :: value !< Set the coupler values to a constant (particularly 0) is desired +! end subroutine g_tracer_coupler_set + +! !> Get coupler values only for tracers that have _ALLOCATED arrays for the fluxes +! !! +! !! Use coupler_util subroutine extract_coupler_values() to get the coupler values +! !! for fluxes to be exchanged with Ice for the requested fluxes only. +! !! NOTE: +! !! This is a collective subroutine and will transverse the list of generic tracers and +! !! get the coupler values for each tracer node accordingly +! subroutine g_tracer_coupler_get(g_tracer_list,IOB_struc, weight, model_time) +! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list +! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node +! type(coupler_2d_bc_type), intent(in) :: IOB_struc !< The coupler flux IOB structure +! real, optional,intent(in) :: weight !< Unknown +! type(time_type), optional,intent(in) :: model_time !< Time +! end subroutine g_tracer_coupler_get + +! !> Unknown +! subroutine g_tracer_coupler_accumulate(g_tracer_list,IOB_struc, weight, model_time) +! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list +! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node +! type(coupler_2d_bc_type), intent(in) :: IOB_struc !< The coupler flux IOB structure +! real, optional,intent(in) :: weight !< Unknown +! type(time_type), optional,intent(in) :: model_time !< Time +! end subroutine g_tracer_coupler_accumulate + + !> Unknown subroutine g_tracer_set_csdiag(diag_CS) - type(g_diag_ctrl), target,intent(in) :: diag_CS - g_tracer_com%diag_CS = diag_CS + type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown end subroutine g_tracer_set_csdiag subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) - real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask - integer,dimension(isd:,jsd:),intent(in) :: grid_kmt - type(time_type), intent(in) :: init_time + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Unknown + real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask !< Unknown + integer,dimension(isd:,jsd:),intent(in) :: grid_kmt !< Unknown + type(time_type), intent(in) :: init_time !< Unknown end subroutine g_tracer_set_common subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) - integer, intent(out) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - integer,optional, intent(out) :: axes(3) - type(time_type), optional, intent(out) :: init_time - real, optional, dimension(:,:,:),pointer :: grid_tmask - integer, optional, dimension(:,:), pointer :: grid_mask_coast - integer, optional, dimension(:,:), pointer :: grid_kmt - type(g_diag_ctrl), optional, pointer :: diag_CS + integer, intent(out) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau !< Unknown + integer,optional, intent(out) :: axes(3) !< Unknown + type(time_type), optional, intent(out) :: init_time !< Unknown + real, optional, dimension(:,:,:),pointer :: grid_tmask !< Unknown + integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown + integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown + type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown end subroutine g_tracer_get_common - subroutine g_tracer_get_diagCS(diag_CS) - type(g_diag_ctrl), pointer :: diag_CS - end subroutine g_tracer_get_diagCS +! subroutine g_tracer_get_diagCS(diag_CS) +! type(g_diag_ctrl), pointer :: diag_CS +! end subroutine g_tracer_get_diagCS - subroutine g_tracer_set_files(ice_restart_file,ocean_restart_file) - character(len=*), intent(in) :: ice_restart_file - character(len=*), intent(in) :: ocean_restart_file - end subroutine g_tracer_set_files +! subroutine g_tracer_set_files(ice_restart_file,ocean_restart_file) +! character(len=*), intent(in) :: ice_restart_file +! character(len=*), intent(in) :: ocean_restart_file +! end subroutine g_tracer_set_files + !> Unknown subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown real, dimension(:,:,:,:), pointer :: array_ptr end subroutine g_tracer_get_4D + !> Unknown subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - real, dimension(:,:,:), pointer :: array_ptr + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, dimension(:,:,:), pointer :: array_ptr !< Unknown end subroutine g_tracer_get_3D + !> Unknown subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - real, dimension(:,:), pointer :: array_ptr + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, dimension(:,:), pointer :: array_ptr !< Unknown end subroutine g_tracer_get_2D + !> Unknown subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - real, dimension(isd:,jsd:,:,:), intent(out):: array + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown end subroutine g_tracer_get_4D_val + !> Unknown subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - integer, optional, intent(in) :: ntau - logical, optional, intent(in) :: positive - real, dimension(isd:,jsd:,:), intent(out):: array + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + logical, optional, intent(in) :: positive !< Unknown + real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown integer :: tau character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' end subroutine g_tracer_get_3D_val + !> Unknown subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - real, dimension(isd:,jsd:), intent(out):: array + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:), intent(out):: array !< Unknown end subroutine g_tracer_get_2D_val + !> Unknown subroutine g_tracer_get_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown real, intent(out):: value end subroutine g_tracer_get_real + !> Unknown subroutine g_tracer_get_string(g_tracer_list,name,member,string) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - character(len=fm_string_len), intent(out) :: string - character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_string' + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + character(len=fm_string_len), intent(out) :: string !< Unknown end subroutine g_tracer_get_string + !> Unknown subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - real, dimension(isd:,jsd:),intent(in) :: array - real, optional ,intent(in) :: weight + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:),intent(in) :: array !< Unknown + real, optional ,intent(in) :: weight !< Unknown end subroutine g_tracer_set_2D + !> Unknown subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - integer, optional, intent(in) :: ntau - real, dimension(isd:,jsd:,:), intent(in) :: array + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + real, dimension(isd:,jsd:,:), intent(in) :: array !< Unknown end subroutine g_tracer_set_3D + !> Unknown subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: isd,jsd - real, dimension(isd:,jsd:,:,:), intent(in) :: array + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(in) :: array !< Unknown end subroutine g_tracer_set_4D + !> Unknown subroutine g_tracer_set_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - real, intent(in) :: value + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, intent(in) :: value !< Unknown end subroutine g_tracer_set_real - subroutine g_tracer_set_pointer_4D(g_tracer_list,name,member,array,ilb,jlb) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: ilb,jlb - real, dimension(ilb:,jlb:,:,:), target, intent(in) :: array - end subroutine g_tracer_set_pointer_4D - - subroutine g_tracer_set_pointer_3D(g_tracer_list,name,member,array,ilb,jlb) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: member - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer, intent(in) :: ilb,jlb - real, dimension(ilb:,jlb:,:), target, intent(in) :: array - end subroutine g_tracer_set_pointer_3D - - subroutine g_tracer_find(g_tracer,name) - character(len=*), intent(in) :: name - type(g_tracer_type), pointer :: g_tracer - end subroutine g_tracer_find - - subroutine g_tracer_column_int(depth, ilb, jlb, var, dzt, rho_dzt, rd, k_level, integral, caller) - real, intent(in) :: depth - integer, intent(in) :: ilb - integer, intent(in) :: jlb - real, dimension(ilb:,jlb:,:), intent(in) :: var - real, dimension(ilb:,jlb:,:), intent(in) :: dzt - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt - real, dimension(ilb:,jlb:,:), intent(inout) :: rd - integer, intent(inout) :: k_level - real, dimension(ilb:,jlb:), intent(out) :: integral - character(len=*), intent(in), optional :: caller - end subroutine g_tracer_column_int - - subroutine g_tracer_flux_at_depth(depth, ilb, jlb, var, dzt, k_level, frac, initialized, flux, caller) - real, intent(in) :: depth - integer, intent(in) :: ilb - integer, intent(in) :: jlb - real, dimension(ilb:,jlb:,:), intent(in) :: var - real, dimension(ilb:,jlb:,:), intent(in) :: dzt - integer, dimension(ilb:,jlb:), intent(inout) :: k_level - real, dimension(ilb:,jlb:), intent(inout) :: frac - logical, intent(inout) :: initialized - real, dimension(ilb:,jlb:), intent(out) :: flux - character(len=*), intent(in), optional :: caller - end subroutine g_tracer_flux_at_depth +! subroutine g_tracer_set_pointer_4D(g_tracer_list,name,member,array,ilb,jlb) +! character(len=*), intent(in) :: name +! character(len=*), intent(in) :: member +! type(g_tracer_type), pointer :: g_tracer_list, g_tracer +! integer, intent(in) :: ilb,jlb +! real, dimension(ilb:,jlb:,:,:), target, intent(in) :: array +! end subroutine g_tracer_set_pointer_4D + +! subroutine g_tracer_set_pointer_3D(g_tracer_list,name,member,array,ilb,jlb) +! character(len=*), intent(in) :: name +! character(len=*), intent(in) :: member +! type(g_tracer_type), pointer :: g_tracer_list, g_tracer +! integer, intent(in) :: ilb,jlb +! real, dimension(ilb:,jlb:,:), target, intent(in) :: array +! end subroutine g_tracer_set_pointer_3D + +! subroutine g_tracer_find(g_tracer,name) +! character(len=*), intent(in) :: name +! type(g_tracer_type), pointer :: g_tracer +! end subroutine g_tracer_find + +! subroutine g_tracer_column_int(depth, ilb, jlb, var, dzt, rho_dzt, rd, k_level, integral, caller) +! real, intent(in) :: depth +! integer, intent(in) :: ilb +! integer, intent(in) :: jlb +! real, dimension(ilb:,jlb:,:), intent(in) :: var +! real, dimension(ilb:,jlb:,:), intent(in) :: dzt +! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt +! real, dimension(ilb:,jlb:,:), intent(inout) :: rd +! integer, intent(inout) :: k_level +! real, dimension(ilb:,jlb:), intent(out) :: integral +! character(len=*), intent(in), optional :: caller +! end subroutine g_tracer_column_int + +! subroutine g_tracer_flux_at_depth(depth, ilb, jlb, var, dzt, k_level, frac, initialized, flux, caller) +! real, intent(in) :: depth +! integer, intent(in) :: ilb +! integer, intent(in) :: jlb +! real, dimension(ilb:,jlb:,:), intent(in) :: var +! real, dimension(ilb:,jlb:,:), intent(in) :: dzt +! integer, dimension(ilb:,jlb:), intent(inout) :: k_level +! real, dimension(ilb:,jlb:), intent(inout) :: frac +! logical, intent(inout) :: initialized +! real, dimension(ilb:,jlb:), intent(out) :: flux +! character(len=*), intent(in), optional :: caller +! end subroutine g_tracer_flux_at_depth subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - type(time_type), intent(in) :: model_time - integer, intent(in) :: tau + type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: tau !< The time step for the %field 4D field to be reported end subroutine g_tracer_send_diag - subroutine g_tracer_diag(g_tracer_list, ilb, jlb, rho_dzt_tau, rho_dzt_taup1, model_time, tau, taup1, dtts) - type(g_tracer_type), pointer :: g_tracer_list - integer, intent(in) :: ilb - integer, intent(in) :: jlb - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 - type(time_type), intent(in) :: model_time - integer, intent(in) :: tau - integer, intent(in) :: taup1 - real, intent(in) :: dtts - end subroutine g_tracer_diag - - subroutine g_tracer_traverse(g_tracer_list) - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - end subroutine g_tracer_traverse - +! subroutine g_tracer_diag(g_tracer_list, ilb, jlb, rho_dzt_tau, rho_dzt_taup1, model_time, tau, taup1, dtts) +! type(g_tracer_type), pointer :: g_tracer_list +! integer, intent(in) :: ilb +! integer, intent(in) :: jlb +! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau +! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 +! type(time_type), intent(in) :: model_time +! integer, intent(in) :: tau +! integer, intent(in) :: taup1 +! real, intent(in) :: dtts +! end subroutine g_tracer_diag + +! subroutine g_tracer_traverse(g_tracer_list) +! type(g_tracer_type), pointer :: g_tracer_list, g_tracer +! end subroutine g_tracer_traverse + + !> Unknown subroutine g_tracer_get_name(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer - character(len=*), intent(out) :: string + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown end subroutine g_tracer_get_name + !> Unknown subroutine g_tracer_get_alias(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer - character(len=*), intent(out) :: string + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown end subroutine g_tracer_get_alias + !> Is the tracer prognostic? function g_tracer_is_prog(g_tracer) logical :: g_tracer_is_prog - type(g_tracer_type), pointer :: g_tracer + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node end function g_tracer_is_prog + !> get the next tracer in the list subroutine g_tracer_get_next(g_tracer,g_tracer_next) - type(g_tracer_type), pointer :: g_tracer,g_tracer_next + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list end subroutine g_tracer_get_next + !>Vertical Diffusion of a tracer node + !! + !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field for a tracer node. + !! This is ported from GOLD (vertdiff) and simplified + !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting tracer concentration + !! has units of mol/Kg subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) type(g_tracer_type), pointer :: g_tracer - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old, ea, eb - real, intent(in) :: dt, kg_m2_to_H, m_to_H - integer, intent(in) :: tau - logical, intent(in), optional :: mom + !> Layer thickness before entrainment, in m or kg m-2. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old + !> The amount of fluid entrained from the layer above, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: ea + !> The amount of fluid entrained from the layer below, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: eb + real, intent(in) :: dt !< The amount of time covered by this call, in s. + real, intent(in) :: kg_m2_to_H !< A conversion factor that translates kg m-2 into + !! the units of h_old (H) + real, intent(in) :: m_to_H !< A conversion factor that translates m into the units + !! of h_old (H). + integer, intent(in) :: tau !< Unknown + logical, intent(in), optional :: mom end subroutine g_tracer_vertdiff_G - subroutine g_tracer_vertdiff_M(g_tracer,dh, dhw, diff_cbt, dt, rho0,tau) - type(g_tracer_type), pointer :: g_tracer - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: dh, diff_cbt - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,0:), intent(in) :: dhw - real, intent(in) :: dt,rho0 - integer, intent(in) :: tau - end subroutine g_tracer_vertdiff_M - - subroutine g_diag_field_add(node_ptr, diag_id, package_name, name, axes, init_time, longname, units, & - missing_value, Z_diag, field_ptr, Zname, Zlongname, Zunits) - type(g_diag_type), pointer :: node_ptr - integer, intent(inout) :: diag_id - character(len=*), intent(in) :: package_name, name - integer, intent(in) :: axes(:) - type(time_type), intent(in) :: init_time - character(len=*), intent(in) :: longname, units - real, optional, intent(in) :: missing_value - integer, optional, intent(in) :: Z_diag - character(len=*), optional, intent(in) :: Zname, Zlongname, Zunits - real, optional, pointer :: field_ptr(:,:,:) - end subroutine g_diag_field_add - - subroutine g_tracer_print_info(g_tracer_list) - type(g_tracer_type), pointer :: g_tracer_list, g_tracer - integer :: num_prog,num_diag - end subroutine g_tracer_print_info - - subroutine g_tracer_get_src_info(g_tracer_list,name,src_file, src_var_name, src_var_unit, src_var_gridspec,& - src_var_record, src_var_valid_min, src_var_valid_max) - type(g_tracer_type), pointer :: g_tracer_list,g_tracer - character(len=*), intent(in) :: name - character(len=*), intent(out):: src_file, src_var_name, src_var_unit, src_var_gridspec - integer, intent(out):: src_var_record - real, intent(out):: src_var_valid_min, src_var_valid_max - end subroutine g_tracer_get_src_info - - function g_register_diag_field(module_name, field_name, axes, init_time, & - long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & - x_cell_method, y_cell_method, v_cell_method, diag_CS) - integer :: g_register_diag_field !< An integer handle for a diagnostic array. - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" - character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(time_type),intent(in) :: init_time !< Time at which a field is first available? - type(g_diag_ctrl),optional, pointer :: diag_CS - integer, optional, intent(in) :: axes(:) - character(len=*), optional, intent(in) :: long_name !< Long name of a field. - character(len=*), optional, intent(in) :: units !< Units of a field. - character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. - real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) - logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) - logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< no clue (not used in MOM?) - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) - character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field - character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field - character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field - character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for - !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. - end function g_register_diag_field - - logical function g_send_data_0d(diag_field_id, field, time, err_msg, diag_CS) - integer, intent(in) :: diag_field_id - real, intent(in) :: field - type(time_type), intent(in), optional :: time - character(len=*), intent(out), optional :: err_msg - type(g_diag_ctrl),optional, pointer :: diag_CS - end function g_send_data_0d - - logical function g_send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg, diag_CS) - integer, intent(in) :: diag_field_id - real, dimension(:), intent(in) :: field - real, intent(in), optional :: weight - real, intent(in), dimension(:), optional :: rmask - type (time_type), intent(in), optional :: time - integer, intent(in), optional :: is_in, ie_in - logical, intent(in), dimension(:), optional :: mask - character(len=*), intent(out), optional :: err_msg - type(g_diag_ctrl),optional, pointer :: diag_CS - end function g_send_data_1d - - logical function g_send_data_2d(diag_field_id, field, time, is_in, js_in, & - & mask, rmask, ie_in, je_in, weight, err_msg, diag_CS) - integer, intent(in) :: diag_field_id - real, intent(in), dimension(:,:) :: field - real, intent(in), optional :: weight - type (time_type), intent(in), optional :: time - integer, intent(in), optional :: is_in, js_in, ie_in, je_in - logical, intent(in), dimension(:,:), optional :: mask - real, intent(in), dimension(:,:),optional :: rmask - character(len=*), intent(out), optional :: err_msg - type(g_diag_ctrl),optional, pointer :: diag_CS - end function g_send_data_2d - - logical function g_send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & - & mask, rmask, ie_in, je_in, ke_in, weight, err_msg, diag_CS) - integer, intent(in) :: diag_field_id - real, dimension(:,:,:), intent(in) :: field - real, intent(in), optional :: weight - type (time_type), intent(in), optional :: time - integer, intent(in), optional :: is_in, js_in, ks_in,ie_in,je_in, ke_in - logical, dimension(:,:,:), intent(in), optional :: mask - real, dimension(:,:,:), intent(in), optional :: rmask - character(len=*), intent(out), optional :: err_msg - type(g_diag_ctrl),optional, pointer :: diag_CS - end function g_send_data_3d +! subroutine g_tracer_vertdiff_M(g_tracer,dh, dhw, diff_cbt, dt, rho0,tau) +! type(g_tracer_type), pointer :: g_tracer +! real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: dh, diff_cbt +! real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,0:), intent(in) :: dhw +! real, intent(in) :: dt,rho0 +! integer, intent(in) :: tau +! end subroutine g_tracer_vertdiff_M + +! subroutine g_diag_field_add(node_ptr, diag_id, package_name, name, axes, init_time, longname, units, & +! missing_value, Z_diag, field_ptr, Zname, Zlongname, Zunits) +! type(g_diag_type), pointer :: node_ptr +! integer, intent(inout) :: diag_id +! character(len=*), intent(in) :: package_name, name +! integer, intent(in) :: axes(:) +! type(time_type), intent(in) :: init_time +! character(len=*), intent(in) :: longname, units +! real, optional, intent(in) :: missing_value +! integer, optional, intent(in) :: Z_diag +! character(len=*), optional, intent(in) :: Zname, Zlongname, Zunits +! real, optional, pointer :: field_ptr(:,:,:) +! end subroutine g_diag_field_add + +! subroutine g_tracer_print_info(g_tracer_list) +! type(g_tracer_type), pointer :: g_tracer_list, g_tracer +! integer :: num_prog,num_diag +! end subroutine g_tracer_print_info + +! subroutine g_tracer_get_src_info(g_tracer_list,name,src_file, src_var_name, src_var_unit, src_var_gridspec,& +! src_var_record, src_var_valid_min, src_var_valid_max) +! type(g_tracer_type), pointer :: g_tracer_list,g_tracer +! character(len=*), intent(in) :: name +! character(len=*), intent(out):: src_file, src_var_name, src_var_unit, src_var_gridspec +! integer, intent(out):: src_var_record +! real, intent(out):: src_var_valid_min, src_var_valid_max +! end subroutine g_tracer_get_src_info + +! function g_register_diag_field(module_name, field_name, axes, init_time, & +! long_name, units, missing_value, range, mask_variant, standard_name, & +! verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & +! cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & +! x_cell_method, y_cell_method, v_cell_method, diag_CS) +! integer :: g_register_diag_field !< An integer handle for a diagnostic array. +! character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" +! character(len=*), intent(in) :: field_name !< Name of the diagnostic field +! type(time_type),intent(in) :: init_time !< Time at which a field is first available? +! type(g_diag_ctrl),optional, pointer :: diag_CS +! integer, optional, intent(in) :: axes(:) +! character(len=*), optional, intent(in) :: long_name !< Long name of a field. +! character(len=*), optional, intent(in) :: units !< Units of a field. +! character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field +! real, optional, intent(in) :: missing_value !< A value that indicates missing values. +! real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) +! logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) +! logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) +! logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) +! character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) +! character(len=*), optional, intent(in) :: interp_method !< no clue (not used in MOM?) +! integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) +! character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field +! character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field +! character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field +! character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field +! character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. +! !! If present, this overrides the default constructed from the default for +! !! each individual axis direction. +! character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. +! character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. +! character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. +! end function g_register_diag_field + +! logical function g_send_data_0d(diag_field_id, field, time, err_msg, diag_CS) +! integer, intent(in) :: diag_field_id +! real, intent(in) :: field +! type(time_type), intent(in), optional :: time +! character(len=*), intent(out), optional :: err_msg +! type(g_diag_ctrl),optional, pointer :: diag_CS +! end function g_send_data_0d + +! logical function g_send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg, diag_CS) +! integer, intent(in) :: diag_field_id +! real, dimension(:), intent(in) :: field +! real, intent(in), optional :: weight +! real, intent(in), dimension(:), optional :: rmask +! type (time_type), intent(in), optional :: time +! integer, intent(in), optional :: is_in, ie_in +! logical, intent(in), dimension(:), optional :: mask +! character(len=*), intent(out), optional :: err_msg +! type(g_diag_ctrl),optional, pointer :: diag_CS +! end function g_send_data_1d + +! logical function g_send_data_2d(diag_field_id, field, time, is_in, js_in, & +! & mask, rmask, ie_in, je_in, weight, err_msg, diag_CS) +! integer, intent(in) :: diag_field_id +! real, intent(in), dimension(:,:) :: field +! real, intent(in), optional :: weight +! type (time_type), intent(in), optional :: time +! integer, intent(in), optional :: is_in, js_in, ie_in, je_in +! logical, intent(in), dimension(:,:), optional :: mask +! real, intent(in), dimension(:,:),optional :: rmask +! character(len=*), intent(out), optional :: err_msg +! type(g_diag_ctrl),optional, pointer :: diag_CS +! end function g_send_data_2d + +! logical function g_send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & +! & mask, rmask, ie_in, je_in, ke_in, weight, err_msg, diag_CS) +! integer, intent(in) :: diag_field_id +! real, dimension(:,:,:), intent(in) :: field +! real, intent(in), optional :: weight +! type (time_type), intent(in), optional :: time +! integer, intent(in), optional :: is_in, js_in, ks_in,ie_in,je_in, ke_in +! logical, dimension(:,:,:), intent(in), optional :: mask +! real, dimension(:,:,:), intent(in), optional :: rmask +! character(len=*), intent(out), optional :: err_msg +! type(g_diag_ctrl),optional, pointer :: diag_CS +! end function g_send_data_3d end module g_tracer_utils From b7d89c0d2246ab587a56baf7463d0157b5e1a5f2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:09:46 +0000 Subject: [PATCH 075/256] Removed commented out APIs --- .../GFDL_ocean_BGC/generic_tracer.F90 | 31 -- .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 387 ------------------ 2 files changed, 418 deletions(-) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 index 19b7532adc..1471adfbcb 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 @@ -12,16 +12,13 @@ module generic_tracer public generic_tracer_init public generic_tracer_register_diag public generic_tracer_source -! public generic_tracer_diag public generic_tracer_update_from_bottom public generic_tracer_coupler_get public generic_tracer_coupler_set -! public generic_tracer_coupler_zero public generic_tracer_end public generic_tracer_get_list public do_generic_tracer public generic_tracer_vertdiff_G -! public generic_tracer_vertdiff_M public generic_tracer_get_diag_list public generic_tracer_coupler_accumulate @@ -58,19 +55,6 @@ subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) type(time_type), optional,intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_accumulate -! !> Do things which must be done after all transports and sources have been calculated -! subroutine generic_tracer_diag(ilb, jlb, tau, taup1, dtts, model_time, dzt, rho_dzt_tau, rho_dzt_taup1) -! integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain -! integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain -! integer, intent(in) :: tau !< Time step index of %field -! integer, intent(in) :: taup1 !< Unknown -! real, intent(in) :: dtts !< Unknown -! type(time_type), intent(in) :: model_time !< Time -! real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] -! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau !< Unknown -! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 !< Unknown -! end subroutine generic_tracer_diag - !> Calls the corresponding generic_X_update_from_source routine for each package X subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& @@ -115,16 +99,6 @@ subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) integer, intent(in) :: tau !< Unknown end subroutine generic_tracer_vertdiff_G -! !> Set the coupler values for each generic tracer -! subroutine generic_tracer_vertdiff_M(dh, dhw, diff_cbt, dt, Rho_0,tau) -! real, dimension(:,:,:), intent(in) :: dh !< Unknown -! real, dimension(:,:,:), intent(in) :: dhw !< Unknown -! real, dimension(:,:,:), intent(in) :: diff_cbt !< Unknown -! real, intent(in) :: dt !< Unknown -! real, intent(in) :: Rho_0 !< Unknown -! integer, intent(in) :: tau !< Unknown -! end subroutine generic_tracer_vertdiff_M - !> Set the coupler values for each generic tracer subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure @@ -139,11 +113,6 @@ subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sos type(time_type),optional, intent(in) :: model_time !< Time end subroutine generic_tracer_coupler_set -! !> Zero out the coupler values for each tracer -! subroutine generic_tracer_coupler_zero(IOB_struc) -! type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure -! end subroutine generic_tracer_coupler_zero - !> End this module by calling the corresponding generic_X_end for each package X subroutine generic_tracer_end end subroutine generic_tracer_end diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 index 185da0052e..ecfbf59fd2 100644 --- a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -46,82 +46,19 @@ module g_tracer_utils type(g_tracer_common), target, save :: g_tracer_com public :: g_tracer_type -! public :: g_tracer_find -! public :: g_tracer_add -! public :: g_tracer_init public :: g_tracer_flux_init -! public :: g_tracer_column_int -! public :: g_tracer_flux_at_depth -! public :: g_tracer_add_param public :: g_tracer_set_values public :: g_tracer_get_values public :: g_tracer_get_pointer public :: g_tracer_get_common public :: g_tracer_set_common public :: g_tracer_set_csdiag -! public :: g_tracer_set_files -! public :: g_tracer_coupler_set -! public :: g_tracer_coupler_get public :: g_tracer_send_diag -! public :: g_tracer_diag public :: g_tracer_get_name public :: g_tracer_get_alias public :: g_tracer_get_next -! public :: g_tracer_register_diag public :: g_tracer_is_prog -! public :: g_tracer_vertdiff_G -! public :: g_tracer_vertdiff_M -! public :: g_tracer_start_param_list -! public :: g_tracer_end_param_list public :: g_diag_type -! public :: g_diag_field_add -! public :: g_tracer_set_pointer -! public :: g_tracer_print_info -! public :: g_tracer_coupler_accumulate -! public :: g_tracer_get_src_info -! public :: g_register_diag_field -! public :: g_send_data - -! !> Add a new parameter for the generic tracer package -! !! -! !! This subroutine is used to add a new parameter by the calling tracer package. -! !! It provides a mechanism for parameter overwrite through the field_table. -! !! For each tracer package there is a field called namelists and there -! !! the parameters can be modified from their value set by this method. -! !! E.g., we may have the following in the field_table -! !! -! !! "namelists","ocean_mod","generic_topaz" -! !! init = t -! !! / -! !! -! !! This will overwrite the parameter topaz%init to be .true. at the run time -! !! even though generic_topaz package had in the code -! !! `call g_tracer_add_param('init', topaz%init, .false. )` -! !! -! !! For the parameters overwrite mechanism to work all calls -! !! for adding new parameters (refer to description for subroutine g_tracer_add_param) -! !! should happen between a `call g_tracer_start_param_list(package_name)` -! !! and a `call g_tracer_end_param_list(package_name)` -! interface g_tracer_add_param -! module procedure g_tracer_add_param_real -! module procedure g_tracer_add_param_logical -! module procedure g_tracer_add_param_integer -! module procedure g_tracer_add_param_string -! end interface - -! !> Unknown -! interface g_tracer_set_pointer -! module procedure g_tracer_set_pointer_3d -! module procedure g_tracer_set_pointer_4d -! end interface g_tracer_set_pointer - -! !> Unknown -! interface g_send_data -! module procedure g_send_data_0d -! module procedure g_send_data_1d -! module procedure g_send_data_2d -! module procedure g_send_data_3d -! end interface !> Set the values of various (array) members of the tracer node g_tracer_type !! @@ -155,147 +92,11 @@ module g_tracer_utils contains -! !> Mark the start of adding new parameters for a package -! !! For the parameters override mechanism to work all calls -! !! for adding new parameters (refer to description for subroutine g_tracer_add_param) -! !! should happen between a `call g_tracer_start_param_list(package_name)` -! !! and a `call g_tracer_end_param_list(package_name)` -! subroutine g_tracer_start_param_list(package_name) -! !> Name of the generic tracer package that is adding the parameters (e.g., "generic_cfc") -! character(len=fm_string_len), intent(in) :: package_name -! end subroutine g_tracer_start_param_list - -! !> Mark the start of adding new parameters for a package -! subroutine g_tracer_end_param_list(package_name) -! !> Name of the generic tracer package that is adding the parameters (e.g., "generic_cfc") -! character(len=fm_string_len) :: package_name -! end subroutine g_tracer_end_param_list - -! !> Overload interface g_tracer_add_param for real parameter -! subroutine g_tracer_add_param_real(name, var, value) -! character(len=*), intent(in) :: name !< Unknown -! real, intent(in) :: value !< Unknown -! real, intent(out) :: var !< Unknown -! end subroutine g_tracer_add_param_real - -! !> Overload interface g_tracer_add_param for logical parameter -! subroutine g_tracer_add_param_logical(name, var, value) -! character(len=*), intent(in) :: name !< Unknown -! logical, intent(in) :: value !< Unknown -! logical, intent(out) :: var !< Unknown -! end subroutine g_tracer_add_param_logical - -! !> Overload interface g_tracer_add_param for integer parameter -! subroutine g_tracer_add_param_integer(name, var, value) -! character(len=*), intent(in) :: name !< Unknown -! integer, intent(in) :: value !< Unknown -! integer, intent(out) :: var !< Unknown -! end subroutine g_tracer_add_param_integer - -! !> Overload interface g_tracer_add_param for string parameter -! subroutine g_tracer_add_param_string(name, var, value) -! character(len=*), intent(in) :: name !< Unknown -! character(len=*), intent(in) :: value !< Unknown -! character(len=*), intent(out) :: var !< Unknown -! end subroutine g_tracer_add_param_string - -! !> Add a new tracer (node) at the top of the list of generic tracers -! !! This subroutine call adds an individual new tracer to the growing list of generic tracers. -! !! It then allocates all the necessary arrays for using this tracer in the Ocean model that requested it. -! !! The information passed into this subroutine should be enough to fully describe the individual tracer -! subroutine g_tracer_add(node_ptr, package, name, longname, units, prog, const_init_value,init_value,& -! flux_gas, flux_gas_name, flux_runoff, flux_wetdep, flux_drydep, flux_gas_molwt, flux_gas_param, & -! flux_param, flux_bottom, btm_reservoir, move_vertical, diff_vertical, sink_rate, flux_gas_restart_file, & -! flux_gas_type, requires_src_info, standard_name,diag_name, diag_field_units,diag_field_scaling_factor, & -! implementation) -! !> Pointer to the head node of the tracer list. This is also going to be the pointer to the node being added after the call -! type(g_tracer_type), pointer :: node_ptr -! character(len=*), intent(in) :: package !< Name of tracer package adding this node -! character(len=*), intent(in) :: name !< Name of this tracer -! character(len=*), intent(in) :: longname !< Descriptive name of this tracer -! character(len=*), intent(in) :: units !< Concentration units (units of array %field) -! logical, intent(in) :: prog !< .true. for prognastic , .false. for diagnostic tracer -! real, intent(in), optional :: const_init_value !< Initial value of concenteration if constant -! real, intent(in), optional :: init_value !< Unknown -! real, intent(in), optional :: sink_rate !< Sinking rate if non-zero -! logical, intent(in), optional :: flux_gas !< .true. if there is gas flux exchange with atmos -! logical, intent(in), optional :: flux_runoff !< .true. if there is runoff flux -! logical, intent(in), optional :: flux_wetdep !< .true. if there is wetdep flux -! logical, intent(in), optional :: flux_drydep !< .true. if there is drydep flux -! logical, intent(in), optional :: flux_bottom !< .true. if there is bottom flux -! logical, intent(in), optional :: btm_reservoir !< .true. if there is bottom reservoir -! logical, intent(in), optional :: move_vertical !< .true. if there is active vertical movement -! logical, intent(in), optional :: diff_vertical !< Unknown -! real, intent(in), optional :: flux_gas_molwt !< Unknown -! real, dimension(:), intent(in), optional :: flux_gas_param !< Array of parameters for gas flux (refer to documentation for subroutine aof_set_coupler_flux() ) -! real, dimension(:), intent(in), optional :: flux_param !< Array of parameters for non-gas flux (refer to documentation for subroutine aof_set_coupler_flux() ) -! character(len=*), intent(in), optional :: flux_gas_name !< Name of the atmospheric tracer to exchange flux with (if flux_gas=.true.) -! character(len=*), intent(in), optional :: implementation !< Unknown -! character(len=*), intent(in), optional :: flux_gas_type !< Unknown -! character(len=*), intent(in), optional :: flux_gas_restart_file !< Unknown -! logical, intent(in), optional :: requires_src_info !< Unknown -! character(len=*), intent(in), optional :: standard_name !< Unknown -! character(len=*), intent(in), optional :: diag_name !< Unknown -! character(len=*), intent(in), optional :: diag_field_units !< Unknown -! real, intent(in), optional :: diag_field_scaling_factor !< Unknown -! end subroutine g_tracer_add - -! !> Unknown -! subroutine g_tracer_init(g_tracer) -! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node -! end subroutine g_tracer_init - !> Unknown subroutine g_tracer_flux_init(g_tracer) type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node end subroutine g_tracer_flux_init -! !> Diag-register all the internal fields that were _ALLOCATED for a tracer -! !! -! !! Use diag_manager register_diag_field for each of the field arrays that were _ALLOCATED for a tracer node. -! !! These include %field, %tendency, %stf, %stf_gas, %deltap, %kw, %btf, %trunoff, %alpha, %csurf, %sc_no, %btm_reservoir. -! subroutine g_tracer_register_diag(g_tracer) -! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node -! end subroutine g_tracer_register_diag - -! !> Set coupler values only for tracers that have _ALLOCATED %alpha, %csurf and %sc_no -! !! -! !! Use coupler_util subroutine set_coupler_values() to set the coupler values -! !! for fluxes to be exchanged with Ice for the requested fluxes. -! !! NOTE: -! !! This is a collective subroutine and will transverse the list of generic tracers and -! !! set the coupler values for each tracer node accordingly. -! subroutine g_tracer_coupler_set(g_tracer_list,IOB_struc,value) -! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list -! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node -! type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< The coupler flux IOB structure -! real, optional :: value !< Set the coupler values to a constant (particularly 0) is desired -! end subroutine g_tracer_coupler_set - -! !> Get coupler values only for tracers that have _ALLOCATED arrays for the fluxes -! !! -! !! Use coupler_util subroutine extract_coupler_values() to get the coupler values -! !! for fluxes to be exchanged with Ice for the requested fluxes only. -! !! NOTE: -! !! This is a collective subroutine and will transverse the list of generic tracers and -! !! get the coupler values for each tracer node accordingly -! subroutine g_tracer_coupler_get(g_tracer_list,IOB_struc, weight, model_time) -! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list -! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node -! type(coupler_2d_bc_type), intent(in) :: IOB_struc !< The coupler flux IOB structure -! real, optional,intent(in) :: weight !< Unknown -! type(time_type), optional,intent(in) :: model_time !< Time -! end subroutine g_tracer_coupler_get - -! !> Unknown -! subroutine g_tracer_coupler_accumulate(g_tracer_list,IOB_struc, weight, model_time) -! type(g_tracer_type), pointer :: g_tracer_list !< Pointer to the head of the generic tracer list -! type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node -! type(coupler_2d_bc_type), intent(in) :: IOB_struc !< The coupler flux IOB structure -! real, optional,intent(in) :: weight !< Unknown -! type(time_type), optional,intent(in) :: model_time !< Time -! end subroutine g_tracer_coupler_accumulate - !> Unknown subroutine g_tracer_set_csdiag(diag_CS) type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown @@ -319,15 +120,6 @@ subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown end subroutine g_tracer_get_common -! subroutine g_tracer_get_diagCS(diag_CS) -! type(g_diag_ctrl), pointer :: diag_CS -! end subroutine g_tracer_get_diagCS - -! subroutine g_tracer_set_files(ice_restart_file,ocean_restart_file) -! character(len=*), intent(in) :: ice_restart_file -! character(len=*), intent(in) :: ocean_restart_file -! end subroutine g_tracer_set_files - !> Unknown subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) character(len=*), intent(in) :: name !< Unknown @@ -436,53 +228,6 @@ subroutine g_tracer_set_real(g_tracer_list,name,member,value) real, intent(in) :: value !< Unknown end subroutine g_tracer_set_real -! subroutine g_tracer_set_pointer_4D(g_tracer_list,name,member,array,ilb,jlb) -! character(len=*), intent(in) :: name -! character(len=*), intent(in) :: member -! type(g_tracer_type), pointer :: g_tracer_list, g_tracer -! integer, intent(in) :: ilb,jlb -! real, dimension(ilb:,jlb:,:,:), target, intent(in) :: array -! end subroutine g_tracer_set_pointer_4D - -! subroutine g_tracer_set_pointer_3D(g_tracer_list,name,member,array,ilb,jlb) -! character(len=*), intent(in) :: name -! character(len=*), intent(in) :: member -! type(g_tracer_type), pointer :: g_tracer_list, g_tracer -! integer, intent(in) :: ilb,jlb -! real, dimension(ilb:,jlb:,:), target, intent(in) :: array -! end subroutine g_tracer_set_pointer_3D - -! subroutine g_tracer_find(g_tracer,name) -! character(len=*), intent(in) :: name -! type(g_tracer_type), pointer :: g_tracer -! end subroutine g_tracer_find - -! subroutine g_tracer_column_int(depth, ilb, jlb, var, dzt, rho_dzt, rd, k_level, integral, caller) -! real, intent(in) :: depth -! integer, intent(in) :: ilb -! integer, intent(in) :: jlb -! real, dimension(ilb:,jlb:,:), intent(in) :: var -! real, dimension(ilb:,jlb:,:), intent(in) :: dzt -! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt -! real, dimension(ilb:,jlb:,:), intent(inout) :: rd -! integer, intent(inout) :: k_level -! real, dimension(ilb:,jlb:), intent(out) :: integral -! character(len=*), intent(in), optional :: caller -! end subroutine g_tracer_column_int - -! subroutine g_tracer_flux_at_depth(depth, ilb, jlb, var, dzt, k_level, frac, initialized, flux, caller) -! real, intent(in) :: depth -! integer, intent(in) :: ilb -! integer, intent(in) :: jlb -! real, dimension(ilb:,jlb:,:), intent(in) :: var -! real, dimension(ilb:,jlb:,:), intent(in) :: dzt -! integer, dimension(ilb:,jlb:), intent(inout) :: k_level -! real, dimension(ilb:,jlb:), intent(inout) :: frac -! logical, intent(inout) :: initialized -! real, dimension(ilb:,jlb:), intent(out) :: flux -! character(len=*), intent(in), optional :: caller -! end subroutine g_tracer_flux_at_depth - subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node @@ -490,22 +235,6 @@ subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) integer, intent(in) :: tau !< The time step for the %field 4D field to be reported end subroutine g_tracer_send_diag -! subroutine g_tracer_diag(g_tracer_list, ilb, jlb, rho_dzt_tau, rho_dzt_taup1, model_time, tau, taup1, dtts) -! type(g_tracer_type), pointer :: g_tracer_list -! integer, intent(in) :: ilb -! integer, intent(in) :: jlb -! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_tau -! real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt_taup1 -! type(time_type), intent(in) :: model_time -! integer, intent(in) :: tau -! integer, intent(in) :: taup1 -! real, intent(in) :: dtts -! end subroutine g_tracer_diag - -! subroutine g_tracer_traverse(g_tracer_list) -! type(g_tracer_type), pointer :: g_tracer_list, g_tracer -! end subroutine g_tracer_traverse - !> Unknown subroutine g_tracer_get_name(g_tracer,string) type(g_tracer_type), pointer :: g_tracer !< Unknown @@ -553,120 +282,4 @@ subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, logical, intent(in), optional :: mom end subroutine g_tracer_vertdiff_G -! subroutine g_tracer_vertdiff_M(g_tracer,dh, dhw, diff_cbt, dt, rho0,tau) -! type(g_tracer_type), pointer :: g_tracer -! real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: dh, diff_cbt -! real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,0:), intent(in) :: dhw -! real, intent(in) :: dt,rho0 -! integer, intent(in) :: tau -! end subroutine g_tracer_vertdiff_M - -! subroutine g_diag_field_add(node_ptr, diag_id, package_name, name, axes, init_time, longname, units, & -! missing_value, Z_diag, field_ptr, Zname, Zlongname, Zunits) -! type(g_diag_type), pointer :: node_ptr -! integer, intent(inout) :: diag_id -! character(len=*), intent(in) :: package_name, name -! integer, intent(in) :: axes(:) -! type(time_type), intent(in) :: init_time -! character(len=*), intent(in) :: longname, units -! real, optional, intent(in) :: missing_value -! integer, optional, intent(in) :: Z_diag -! character(len=*), optional, intent(in) :: Zname, Zlongname, Zunits -! real, optional, pointer :: field_ptr(:,:,:) -! end subroutine g_diag_field_add - -! subroutine g_tracer_print_info(g_tracer_list) -! type(g_tracer_type), pointer :: g_tracer_list, g_tracer -! integer :: num_prog,num_diag -! end subroutine g_tracer_print_info - -! subroutine g_tracer_get_src_info(g_tracer_list,name,src_file, src_var_name, src_var_unit, src_var_gridspec,& -! src_var_record, src_var_valid_min, src_var_valid_max) -! type(g_tracer_type), pointer :: g_tracer_list,g_tracer -! character(len=*), intent(in) :: name -! character(len=*), intent(out):: src_file, src_var_name, src_var_unit, src_var_gridspec -! integer, intent(out):: src_var_record -! real, intent(out):: src_var_valid_min, src_var_valid_max -! end subroutine g_tracer_get_src_info - -! function g_register_diag_field(module_name, field_name, axes, init_time, & -! long_name, units, missing_value, range, mask_variant, standard_name, & -! verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & -! cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & -! x_cell_method, y_cell_method, v_cell_method, diag_CS) -! integer :: g_register_diag_field !< An integer handle for a diagnostic array. -! character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" -! character(len=*), intent(in) :: field_name !< Name of the diagnostic field -! type(time_type),intent(in) :: init_time !< Time at which a field is first available? -! type(g_diag_ctrl),optional, pointer :: diag_CS -! integer, optional, intent(in) :: axes(:) -! character(len=*), optional, intent(in) :: long_name !< Long name of a field. -! character(len=*), optional, intent(in) :: units !< Units of a field. -! character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field -! real, optional, intent(in) :: missing_value !< A value that indicates missing values. -! real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) -! logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) -! logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) -! logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) -! character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) -! character(len=*), optional, intent(in) :: interp_method !< no clue (not used in MOM?) -! integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) -! character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field -! character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field -! character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field -! character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field -! character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. -! !! If present, this overrides the default constructed from the default for -! !! each individual axis direction. -! character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. -! character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. -! character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. -! end function g_register_diag_field - -! logical function g_send_data_0d(diag_field_id, field, time, err_msg, diag_CS) -! integer, intent(in) :: diag_field_id -! real, intent(in) :: field -! type(time_type), intent(in), optional :: time -! character(len=*), intent(out), optional :: err_msg -! type(g_diag_ctrl),optional, pointer :: diag_CS -! end function g_send_data_0d - -! logical function g_send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg, diag_CS) -! integer, intent(in) :: diag_field_id -! real, dimension(:), intent(in) :: field -! real, intent(in), optional :: weight -! real, intent(in), dimension(:), optional :: rmask -! type (time_type), intent(in), optional :: time -! integer, intent(in), optional :: is_in, ie_in -! logical, intent(in), dimension(:), optional :: mask -! character(len=*), intent(out), optional :: err_msg -! type(g_diag_ctrl),optional, pointer :: diag_CS -! end function g_send_data_1d - -! logical function g_send_data_2d(diag_field_id, field, time, is_in, js_in, & -! & mask, rmask, ie_in, je_in, weight, err_msg, diag_CS) -! integer, intent(in) :: diag_field_id -! real, intent(in), dimension(:,:) :: field -! real, intent(in), optional :: weight -! type (time_type), intent(in), optional :: time -! integer, intent(in), optional :: is_in, js_in, ie_in, je_in -! logical, intent(in), dimension(:,:), optional :: mask -! real, intent(in), dimension(:,:),optional :: rmask -! character(len=*), intent(out), optional :: err_msg -! type(g_diag_ctrl),optional, pointer :: diag_CS -! end function g_send_data_2d - -! logical function g_send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & -! & mask, rmask, ie_in, je_in, ke_in, weight, err_msg, diag_CS) -! integer, intent(in) :: diag_field_id -! real, dimension(:,:,:), intent(in) :: field -! real, intent(in), optional :: weight -! type (time_type), intent(in), optional :: time -! integer, intent(in), optional :: is_in, js_in, ks_in,ie_in,je_in, ke_in -! logical, dimension(:,:,:), intent(in), optional :: mask -! real, dimension(:,:,:), intent(in), optional :: rmask -! character(len=*), intent(out), optional :: err_msg -! type(g_diag_ctrl),optional, pointer :: diag_CS -! end function g_send_data_3d - end module g_tracer_utils From 0c7e98c02f513c52dc721e3d5e05aa7dc98b7fbc Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:21:07 +0000 Subject: [PATCH 076/256] Doxumented MOM_generic_tracers CS --- src/tracer/MOM_generic_tracer.F90 | 33 ++++++++++++++++--------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 619f56000a..236668e829 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -1,3 +1,4 @@ +!> Drives the generic version of tracers TOPAZ and CFC and other GFDL BGC components module MOM_generic_tracer ! This file is part of MOM6. See LICENSE.md for the license. @@ -6,6 +7,7 @@ module MOM_generic_tracer #include + ! ### These imports should not reach into FMS directly ### use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE use field_manager_mod, only: fm_get_index,fm_string_len @@ -55,25 +57,24 @@ module MOM_generic_tracer public MOM_generic_tracer_min_max public MOM_generic_tracer_fluxes_accumulate + !> Control structure for generic tracers type, public :: MOM_generic_tracer_CS ; private - character(len = 200) :: IC_file ! The file in which the generic tracer initial values can - ! be found, or an empty string for internal initialization. - logical :: Z_IC_file ! If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 ! The initial value assigned to tracers. - real :: tracer_land_val = -1.0 ! The values of tracers used where land is masked out. - logical :: tracers_may_reinit ! If true, tracers may go through the - ! initialization code if they are not found in the - ! restart files. - - 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() - - ! The following pointer will be directed to the first element of the - ! linked list of generic tracers. + character(len = 200) :: IC_file !< The file in which the generic tracer initial values can + !! be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers. + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out. + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + 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() !< Restart control structure + + !> Pointer to the first element of the linked list of generic tracers. type(g_tracer_type), pointer :: g_tracer_list => NULL() - integer :: H_to_m !Auxiliary to access GV%H_to_m in routines that do not have access to GV + integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV end type MOM_generic_tracer_CS From 788f4d703d78ee52e541a098a12a4c3c33fb3efc Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:23:00 +0000 Subject: [PATCH 077/256] Renamed external_APIs to external --- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 0 config_src/{external_APIs => external}/GFDL_ocean_BGC/README.md | 0 .../{external_APIs => external}/GFDL_ocean_BGC/fms_platform.h | 0 .../{external_APIs => external}/GFDL_ocean_BGC/generic_tracer.F90 | 0 .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 0 config_src/{external_APIs => external}/README.md | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename config_src/{external_APIs => external}/GFDL_ocean_BGC/FMS_coupler_util.F90 (100%) rename config_src/{external_APIs => external}/GFDL_ocean_BGC/README.md (100%) rename config_src/{external_APIs => external}/GFDL_ocean_BGC/fms_platform.h (100%) rename config_src/{external_APIs => external}/GFDL_ocean_BGC/generic_tracer.F90 (100%) rename config_src/{external_APIs => external}/GFDL_ocean_BGC/generic_tracer_utils.F90 (100%) rename config_src/{external_APIs => external}/README.md (100%) diff --git a/config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 similarity index 100% rename from config_src/external_APIs/GFDL_ocean_BGC/FMS_coupler_util.F90 rename to config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 diff --git a/config_src/external_APIs/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md similarity index 100% rename from config_src/external_APIs/GFDL_ocean_BGC/README.md rename to config_src/external/GFDL_ocean_BGC/README.md diff --git a/config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h b/config_src/external/GFDL_ocean_BGC/fms_platform.h similarity index 100% rename from config_src/external_APIs/GFDL_ocean_BGC/fms_platform.h rename to config_src/external/GFDL_ocean_BGC/fms_platform.h diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 similarity index 100% rename from config_src/external_APIs/GFDL_ocean_BGC/generic_tracer.F90 rename to config_src/external/GFDL_ocean_BGC/generic_tracer.F90 diff --git a/config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 similarity index 100% rename from config_src/external_APIs/GFDL_ocean_BGC/generic_tracer_utils.F90 rename to config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 diff --git a/config_src/external_APIs/README.md b/config_src/external/README.md similarity index 100% rename from config_src/external_APIs/README.md rename to config_src/external/README.md From 372c1563b95e19a5278f349e2208f039c8e16c94 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:30:33 +0000 Subject: [PATCH 078/256] Fixed a line length issue --- config_src/external/GFDL_ocean_BGC/generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 index 1471adfbcb..bfbc846af9 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 @@ -33,7 +33,7 @@ end subroutine generic_tracer_register !> Initialize generic tracers subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Domain boundaries and axes + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Domain boundaries and axes type(time_type), intent(in) :: init_time !< Time real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column From ad927702794c598f1292df06519311a43d7fb382 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:35:49 +0000 Subject: [PATCH 079/256] Fixed another line length issue --- .../external/GFDL_ocean_BGC/generic_tracer_utils.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index ecfbf59fd2..fbff35aa63 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -261,10 +261,10 @@ end subroutine g_tracer_get_next !>Vertical Diffusion of a tracer node !! - !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field for a tracer node. - !! This is ported from GOLD (vertdiff) and simplified - !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting tracer concentration - !! has units of mol/Kg + !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field + !! for a tracer node.This is ported from GOLD (vertdiff) and simplified + !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting + !! tracer concentrationhas units of mol/Kg subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) type(g_tracer_type), pointer :: g_tracer !> Layer thickness before entrainment, in m or kg m-2. From 0b893e12560691405c1827e2228f0ea4d3fba6f2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 22:46:46 +0000 Subject: [PATCH 080/256] Another undocumented variable, this time illegal! - Added note to remove the variable --- src/tracer/MOM_generic_tracer.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 236668e829..b031488e23 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -47,6 +47,9 @@ module MOM_generic_tracer implicit none ; private + + !> An state hidden in module data that is very much not allowed in MOM6 + ! ### This needs to be fixed logical :: g_registered = .false. public register_MOM_generic_tracer, initialize_MOM_generic_tracer From ef50f67c64719e9a5d3b0ee7f6613509139c7bf6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 23:08:05 +0000 Subject: [PATCH 081/256] Fixed .testing Makefile to work with external - After renaming external_APIs to external, the Makefile in .testing needed to be changed. --- .testing/Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index b5086da31f..18de8c658c 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -86,10 +86,10 @@ SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) \ - $(wildcard ../config_src/external_APIs/*/*.F90) + $(wildcard ../config_src/ext*/*/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/solo_driver/*.F90) \ - $(wildcard build/target_codebase/config_src/external_APIs/*.F90) + $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) #--- @@ -135,7 +135,7 @@ build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_SOURCE) cd $(@D) && $(LIST_PATHS) -l \ ../../$(TARGET_CODEBASE)/src \ ../../$(TARGET_CODEBASE)/config_src/solo_driver \ - ../../$(TARGET_CODEBASE)/config_src/external_APIs \ + ../../$(TARGET_CODEBASE)/config_src/ext* \ ../../$(TARGET_CODEBASE)/$(GRID_SRC) build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) @@ -143,7 +143,7 @@ build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) cd $(@D) && $(LIST_PATHS) -l \ ../../../src \ ../../../config_src/solo_driver \ - ../../../config_src/external_APIs \ + ../../../config_src/ext* \ ../../../$(GRID_SRC) # Target repository for regression tests From 6c622c65b09311a8fd3d209dace8b2b923420473 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 12 Jun 2020 23:15:32 +0000 Subject: [PATCH 082/256] Corrected path in external/README/md - After renaming external_APIs to external, the readme became out of date. --- config_src/external/README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/external/README.md b/config_src/external/README.md index 09af71e22d..ff70f35915 100644 --- a/config_src/external/README.md +++ b/config_src/external/README.md @@ -1,5 +1,5 @@ -config_src/external_APIs -======================== +config_src/external +=================== Subdirectories in here provide null versions of external packages that can be called by, or used with, MOM6 but that are not needed in all From b4d3c15dcc9cad236fc9f3850083c6631d5f2ee3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 16 Jun 2020 13:10:50 -0400 Subject: [PATCH 083/256] +Add 4 optional args to log_version & doc_module Added 4 new optional arguments (log_to_all, all_default, layout, and debugging) to log_version and equivalent argments to doc_module to control which files will have lines documenting modules. These new arguments are now used in close_file_param. All answers are bitwise identical, but there are additions and removals of module decription lines in the MOM_parameter_doc files. --- src/framework/MOM_document.F90 | 24 +++++++++++++++++++++--- src/framework/MOM_file_parser.F90 | 25 ++++++++++++++++++++----- 2 files changed, 41 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index b122a5b6f0..1a732533b0 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -756,13 +756,21 @@ end function undef_string ! ---------------------------------------------------------------------- !> This subroutine handles the module documentation -subroutine doc_module(doc, modname, desc) +subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, debuggingMod) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: modname !< The name of the module being documented character(len=*), intent(in) :: desc !< A description of the module being documented -! This subroutine handles the module documentation + logical, optional, intent(in) :: log_to_all !< If present and true, log this parameter to the + !! ..._doc.all files, even if this module also has layout + !! or debugging parameters. + logical, optional, intent(in) :: all_default !< If true, all parameters take their default values. + logical, optional, intent(in) :: layoutMod !< If present and true, this module has layout parameters. + logical, optional, intent(in) :: debuggingMod !< If present and true, this module has debugging parameters. + + ! This subroutine handles the module documentation character(len=mLen) :: mesg + logical :: repeat_doc if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -770,7 +778,17 @@ subroutine doc_module(doc, modname, desc) if (doc%filesAreOpen) then call writeMessageAndDesc(doc, '', '') ! Blank line for delineation mesg = "! === module "//trim(modname)//" ===" - call writeMessageAndDesc(doc, mesg, desc, indent=0) + call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0, & + layoutParam=layoutMod, debuggingParam=debuggingMod) + if (present(log_to_all)) then ; if (log_to_all) then + ! Log the module version again if the previous call was intercepted for use to document + ! a layout or debugging module. + repeat_doc = .false. + if (present(layoutMod)) then ; if (layoutMod) repeat_doc = .true. ; endif + if (present(debuggingMod)) then ; if (debuggingMod) repeat_doc = .true. ; endif + if (repeat_doc) & + call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0) + endif ; endif endif end subroutine doc_module diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 0cf049b61b..a07d828e5b 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -246,6 +246,7 @@ subroutine close_param_file(CS, quiet_close, component) character(len=*), optional, intent(in) :: component !< If present, this component name is used !! to generate parameter documentation file names ! Local variables + logical :: all_default character(len=128) :: docfile_default character(len=40) :: mdl ! This module's name. ! This include declares and sets the variable "version". @@ -269,8 +270,18 @@ subroutine close_param_file(CS, quiet_close, component) endif ; endif ! Log the parameters for the parser. + docfile_default = "MOM_parameter_doc" + if (present(component)) docfile_default = trim(component)//"_parameter_doc" + + all_default = (CS%log_to_stdout .eqv. log_to_stdout_default) + all_default = all_default .and. (trim(CS%doc_file) == trim(docfile_default)) + if (len_trim(CS%doc_file) > 0) then + all_default = all_default .and. (CS%complete_doc .eqv. complete_doc_default) + all_default = all_default .and. (CS%minimal_doc .eqv. minimal_doc_default) + endif + mdl = "MOM_file_parser" - call log_version(CS, mdl, version, "") + call log_version(CS, mdl, version, "", debugging=.true., log_to_all=.true., all_default=all_default) call log_param(CS, mdl, "SEND_LOG_TO_STDOUT", CS%log_to_stdout, & "If true, all log messages are also sent to stdout.", & default=log_to_stdout_default) @@ -282,8 +293,6 @@ subroutine close_param_file(CS, quiet_close, component) "If true, kill the run if there are any unused "//& "parameters.", default=unused_params_fatal_default, & debuggingParam=.true.) - docfile_default = "MOM_parameter_doc" - if (present(component)) docfile_default = trim(component)//"_parameter_doc" call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & "The basename for files where run-time parameters, their "//& "settings, units and defaults are documented. Blank will "//& @@ -1240,11 +1249,17 @@ end function overrideWarningHasBeenIssued !> Log the version of a module to a log file and/or stdout, and/or to the !! parameter documentation file. -subroutine log_version_cs(CS, modulename, version, desc) +subroutine log_version_cs(CS, modulename, version, desc, log_to_all, all_default, layout, debugging) type(param_file_type), intent(in) :: CS !< File parser type character(len=*), intent(in) :: modulename !< Name of calling module character(len=*), intent(in) :: version !< Version string of module character(len=*), optional, intent(in) :: desc !< Module description + logical, optional, intent(in) :: log_to_all !< If present and true, log this parameter to the + !! ..._doc.all files, even if this module also has layout + !! or debugging parameters. + logical, optional, intent(in) :: all_default !< If true, all parameters take their default values. + logical, optional, intent(in) :: layout !< If present and true, this module has layout parameters. + logical, optional, intent(in) :: debugging !< If present and true, this module has debugging parameters. ! Local variables character(len=240) :: mesg @@ -1254,7 +1269,7 @@ subroutine log_version_cs(CS, modulename, version, desc) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - if (present(desc)) call doc_module(CS%doc, modulename, desc) + if (present(desc)) call doc_module(CS%doc, modulename, desc, log_to_all, all_default, layout, debugging) end subroutine log_version_cs From 5a807f664549039c3c9cb0932a7e1b6439952bfa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 16 Jun 2020 14:00:25 -0400 Subject: [PATCH 084/256] +Record halo sizes in MOM_parameter_doc.all files Log the values of NIHALO and NJHALO in the MOM_parameter_doc.all and MOM_parameter_doc.short files, and corrected the reported default values of the halo sizes so they now match the actual default values. All solutions are bitwise identical, and we should now be able to use the MOM_parameter_doc.short files to recreate solutions. There are changes in the MOM_parameter_doc and SIS_parameter_doc files for all test cases. --- src/framework/MOM_domains.F90 | 52 +++++++++++++++++------------------ 1 file changed, 25 insertions(+), 27 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 477ebd70df..2f31d50607 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1261,7 +1261,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, & "If true, the domain is zonally reentrant.", default=.true.) call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & @@ -1336,26 +1336,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "at run time. This can only be set at compile time.",& layoutParam=.true.) - call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & - "The number of halo points on each side in the "//& - "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ "//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& - "the default is NIHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & - default=4, static_value=nihalo_dflt, layoutParam=.true.) - call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & - "The number of halo points on each side in the "//& - "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ "//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& - "the default is NJHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & - default=4, static_value=njhalo_dflt, layoutParam=.true.) - if (present(min_halo)) then - MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) - min_halo(1) = MOM_dom%nihalo - MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) - min_halo(2) = MOM_dom%njhalo - call log_param(param_file, mdl, "!NIHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) - call log_param(param_file, mdl, "!NJHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) - endif if (is_static) then call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & "The total number of thickness grid points in the "//& @@ -1372,12 +1352,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (MOM_dom%njglobal /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") - if (.not.present(min_halo)) then - if (MOM_dom%nihalo /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(nihalo_nm)//" domain size") - if (MOM_dom%njhalo /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(njhalo_nm)//" domain size") - endif else call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & "The total number of thickness grid points in the "//& @@ -1391,6 +1365,30 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & fail_if_missing=.true.) endif + call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & + "The number of halo points on each side in the x-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=nihalo_dflt, static_value=nihalo_dflt) + call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & + "The number of halo points on each side in the y-direction. How this is set "//& + "varies with the calling component and static or dynamic memory configuration.", & + default=njhalo_dflt, static_value=njhalo_dflt) + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + ! These are generally used only with static memory, so they are considerd layout params. + call log_param(param_file, mdl, "!NIHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) + call log_param(param_file, mdl, "!NJHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) + endif + if (is_static .and. .not.present(min_halo)) then + if (MOM_dom%nihalo /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(nihalo_nm)//" domain size") + if (MOM_dom%njhalo /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(njhalo_nm)//" domain size") + endif + global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal From cf80f4b29da33337aa15d6238c4cac4256d77108 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 16 Jun 2020 14:34:19 -0400 Subject: [PATCH 085/256] +Log modules to parameter_doc.debug files Added optional arguments to various log_version calls so that the module names and descriptions are added to the MOM_parameter_doc.debug and ..._doc.layout files. All answers are bitwise identical, but there are changes to some of the MOM_parameter_doc files. --- .../coupled_driver/MOM_surface_forcing_gfdl.F90 | 2 +- src/core/MOM.F90 | 11 +++++------ src/core/MOM_grid.F90 | 3 ++- src/core/MOM_verticalGrid.F90 | 3 ++- src/diagnostics/MOM_PointAccel.F90 | 8 ++++---- src/diagnostics/MOM_debugging.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/framework/MOM_hor_index.F90 | 2 +- src/framework/MOM_unit_scaling.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- 10 files changed, 19 insertions(+), 18 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 7d2814da93..2a05b2da65 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1272,7 +1272,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call write_version_number(version) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2ff06b85f0..1b8739a14a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1705,8 +1705,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call find_obsolete_params(param_file) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, CS%US) + US => CS%US + ! Read relevant parameters and write them to the model log. - call log_version(param_file, "MOM", version, "") + call log_version(param_file, "MOM", version, "", log_to_all=.true., layout=.true., debugging=.true.) call get_param(param_file, "MOM", "VERBOSITY", verbosity, & "Integer controlling level of messaging\n" // & "\t0 = Only FATAL messages\n" // & @@ -1719,11 +1723,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call unit_tests(verbosity) endif - ! Determining the internal unit scaling factors for this run. - call unit_scaling_init(param_file, CS%US) - - US => CS%US - call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) if (CS%split) then diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f2c4a7d93b..f6c8b44986 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -211,7 +211,8 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Read all relevant parameters and write them to the model log. call log_version(param_file, mod_nm, version, & - "Parameters providing information about the lateral grid.") + "Parameters providing information about the lateral grid.", & + log_to_all=.true., layout=.true.) call get_param(param_file, mod_nm, "NIBLOCK", niblock, "The number of blocks "// & diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 2823175b23..6e65d38c8a 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -92,7 +92,8 @@ 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.") + "Parameters providing information about the vertical grid.", & + log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "G_EARTH", GV%g_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 4ad1b67314..f6326b06fa 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -759,7 +759,7 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", debugging=.true.) call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & "The absolute path to the file where the accelerations "//& "leading to zonal velocity truncations are written. \n"//& @@ -771,7 +771,7 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & - "The maximum number of colums of truncations that any PE "//& + "The maximum number of columns of truncations that any PE "//& "will write out during a run.", default=50, debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then @@ -779,8 +779,8 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%u_trunc_file = trim(dirs%output_directory)//trim(CS%u_trunc_file) if (len_trim(CS%v_trunc_file) > 0) & CS%v_trunc_file = trim(dirs%output_directory)//trim(CS%v_trunc_file) - call log_param(param_file, mdl, "output_dir/U_TRUNC_FILE", CS%u_trunc_file) - call log_param(param_file, mdl, "output_dir/V_TRUNC_FILE", CS%v_trunc_file) + call log_param(param_file, mdl, "output_dir/U_TRUNC_FILE", CS%u_trunc_file, debuggingParam=.true.) + call log_param(param_file, mdl, "output_dir/V_TRUNC_FILE", CS%v_trunc_file, debuggingParam=.true.) endif CS%u_file = -1 ; CS%v_file = -1 ; CS%cols_written = 0 diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 29f7f0f123..43c9c8c406 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -83,7 +83,7 @@ subroutine MOM_debugging_init(param_file) #include "version_variable.h" character(len=40) :: mdl = "MOM_debugging" ! This module's name. - call log_version(param_file, mdl, version) + call log_version(param_file, mdl, version, debugging=.true.) call get_param(param_file, mdl, "DEBUG", debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 81f1e3cf15..e08c920c60 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1478,7 +1478,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag do_not_log=.true.) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version) + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_COLUMN_FRACTION", CS%mono_N2_column_fraction, & "The lower fraction of water column over which N2 is limited as monotonic "// & "for the purposes of calculating the equivalent barotropic wave speed.", & diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index fc833eeea9..a37c76ce41 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -81,7 +81,7 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) ! Read all relevant parameters and write them to the model log. call log_version(param_file, "MOM_hor_index", version, & - "Sets the horizontal array index types.") + "Sets the horizontal array index types.", all_default=.true.) HI%IscB = HI%isc ; HI%JscB = HI%jsc HI%IsdB = HI%isd ; HI%JsdB = HI%jsd diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index ffd2452c19..fea1ac4910 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -75,7 +75,7 @@ subroutine unit_scaling_init( param_file, US ) 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.") + "Parameters for doing unit scaling of variables.", debugging=.true.) 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.", & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 146acc4394..6e1fd8fac9 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1571,7 +1571,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 ! Default, read and log parameters - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.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=.false.) From 85b784d299b3e34c295e0e26b1586929a40e04e7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 16 Jun 2020 14:41:35 -0400 Subject: [PATCH 086/256] +Do not log modules to parameter_doc.short files Added optional arguments to various log_version calls so that the module names and descriptions of unused modules are not added to the MOM_parameter_doc.short files. All answers are bitwise identical, but there are changes to some of the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 4 +++- src/core/MOM_open_boundary.F90 | 5 ++++- src/parameterizations/lateral/MOM_MEKE.F90 | 3 ++- .../lateral/MOM_mixed_layer_restrat.F90 | 4 +++- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 3 ++- src/parameterizations/vertical/MOM_CVMix_conv.F90 | 4 +++- src/parameterizations/vertical/MOM_CVMix_ddiff.F90 | 4 +++- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 5 ++++- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 3 ++- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 7 ++++++- src/tracer/MOM_lateral_boundary_diffusion.F90 | 9 +++++---- src/tracer/MOM_neutral_diffusion.F90 | 10 +++++----- 12 files changed, 42 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9b5a2c1a57..50ad121b77 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3966,7 +3966,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SPLIT", CS%split, default=.true., do_not_log=.true.) + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=CS%split, & + debugging=CS%split, all_default=.not.CS%split) call get_param(param_file, mdl, "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) if (.not.CS%split) return diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 1f973f39ca..bf3d24a790 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -343,9 +343,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] allocate(OBC) + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & + default=0, do_not_log=.true.) call log_version(param_file, mdl, version, & "Controls where open boundaries are located, what kind of boundary condition "//& - "to impose, and what data to apply, if any.") + "to impose, and what data to apply, if any.", & + all_default=(OBC%number_of_segments<=0)) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & "The number of open boundary segments.", & default=0) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index dbb0a41506..5cbbe9b302 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1007,7 +1007,8 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ! Determine whether this module will be used - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USE_MEKE", MEKE_init, default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.MEKE_init) call get_param(param_file, mdl, "USE_MEKE", MEKE_init, & "If true, turns on the MEKE scheme which calculates "// & "a sub-grid mesoscale eddy kinetic energy budget.", & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0a6eac4007..37bbaa4230 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -812,7 +812,9 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, integer :: i, j ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.mixedlayer_restrat_init) call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & "If true, a density-gradient dependent re-stratifying "//& "flow is imposed in the mixed layer. Can be used in ALE mode "//& diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 3b7420aa54..f9115b1041 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -199,8 +199,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'Control structure has already been initialized') ! Read parameters + call get_param(paramFile, mdl, "USE_KPP", KPP_init, default=.false., do_not_log=.true.) call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & - 'See http://cvmix.github.io/') + 'See http://cvmix.github.io/', all_default=.not.KPP_init) call get_param(paramFile, mdl, "USE_KPP", KPP_init, & "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "// & "to calculate diffusivities and non-local transport in the OBL.", & diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 06974095e1..b0cac10e03 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -76,8 +76,10 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! Read parameters + call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "Parameterization of enhanced mixing due to convection via CVMix") + "Parameterization of enhanced mixing due to convection via CVMix", & + all_default=.not.CVMix_conv_init) call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, & "If true, turns on the enhanced mixing due to convection "//& "via CVMix. This scheme increases diapycnal diffs./viscs. "//& diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 94cb958632..8407cca459 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -79,8 +79,10 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! Read parameters + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "Parameterization of mixing due to double diffusion processes via CVMix") + "Parameterization of mixing due to double diffusion processes via CVMix", & + all_default=.not.CVMix_ddiff_init) call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & "If true, turns on double diffusive processes via CVMix. "//& "Note that double diffusive processes on viscosity are ignored "//& diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index f099305f0c..68a56d3597 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -221,8 +221,11 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! Set default, read and log parameters + call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "Parameterization of shear-driven turbulence via CVMix (various options)") + "Parameterization of shear-driven turbulence via CVMix (various options)", & + all_default=.not.(CS%use_PP81.or.CS%use_LMD94)) call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9db2b4742b..cc7fc55a3c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3223,7 +3223,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Set default, read and log parameters call log_version(param_file, mdl, version, & - "The following parameters are used for diabatic processes.") + "The following parameters are used for diabatic processes.", & + log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic, & "If true, use a legacy version of the diabatic subroutine. "//& "This is temporary and is needed to avoid change in answers.", & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 4b0ead8b0d..262c1a83b8 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -249,8 +249,13 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag ! Read parameters + call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & + default=CS%use_CVMix_tidal, do_not_log=.true.) call log_version(param_file, mdl, version, & - "Vertical Tidal Mixing Parameterization") + "Vertical Tidal Mixing Parameterization", & + all_default=.not.(CS%use_CVMix_tidal .or. CS%int_tide_dissipation)) call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & "If true, turns on tidal mixing via CVMix", & default=.false.) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index f244931376..4e038e7844 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -80,15 +80,16 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab endif ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & + default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "This module implements lateral diffusion of tracers near boundaries") + "This module implements lateral diffusion of tracers near boundaries", & + all_default=.not.lateral_boundary_diffusion_init) call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & "If true, enables the lateral boundary tracer's diffusion module.", & default=.false.) - if (.not. lateral_boundary_diffusion_init) then - return - endif + if (.not. lateral_boundary_diffusion_init) return allocate(CS) CS%diag => diag diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index c3c46d85a8..4e05a44218 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -134,17 +134,17 @@ logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diab return endif - ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", neutral_diffusion_init, & + default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "This module implements neutral diffusion of tracers") + "This module implements neutral diffusion of tracers", & + all_default=.not.neutral_diffusion_init) call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", neutral_diffusion_init, & "If true, enables the neutral diffusion module.", & default=.false.) - if (.not.neutral_diffusion_init) then - return - endif + if (.not.neutral_diffusion_init) return allocate(CS) CS%diag => diag From f5dfef89ab22c2acc0c7c67fae9d0cb7de58bfb3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 16 Jun 2020 14:50:21 -0400 Subject: [PATCH 087/256] +Do not log parameters from unused modules Modified the get_param calls to avoid logging parameters from MOM_kappa_shear and MOM_regularize_layers (apart from the main switch to enable these modules) when those modules are not in use. There are also two clocks and a diagnostic that are meaningless when REGULARIZE_SURFACE_LAYERS is false that are no longer set in that case. Also corrected two comments in advect_x and advect_y. All answers are bitwise identical, but there are changes to some of the MOM_parameter_doc and available_diags files. --- .../vertical/MOM_kappa_shear.F90 | 65 ++++++++++--------- .../vertical/MOM_regularize_layers.F90 | 37 ++++++----- src/tracer/MOM_tracer_advect.F90 | 4 +- 3 files changed, 58 insertions(+), 48 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 12d9bfc9c0..7db9be0018 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1975,8 +1975,9 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables logical :: merge_mixedlayer -! This include declares and sets the variable "version". -#include "version_variable.h" + logical :: just_read ! If true, this module is not used, so only read the parameters. + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. real :: kappa_0_unscaled ! The value of kappa_0 in MKS units [m2 s-1] real :: KD_normal ! The KD of the main model, read here only as a parameter @@ -1999,68 +2000,72 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! subgridscale inhomogeneity into account. ! Set default, read and log parameters + call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008") + "Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008", & + log_to_all=.true., debugging=kappa_shear_init, all_default=.not.kappa_shear_init) call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, & "If true, use the Jackson-Hallberg-Legg (JPO 2008) "//& "shear mixing parameterization.", default=.false.) + just_read = .not.kappa_shear_init call get_param(param_file, mdl, "VERTEX_SHEAR", CS%KS_at_vertex, & "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & - default=.false.) + default=.false., do_not_log=just_read) call get_param(param_file, mdl, "RINO_CRIT", CS%RiNo_crit, & "The critical Richardson number for shear mixing.", & - units="nondim", default=0.25) + units="nondim", default=0.25, do_not_log=just_read) call get_param(param_file, mdl, "SHEARMIX_RATE", CS%Shearmix_rate, & "A nondimensional rate scale for shear-driven entrainment. "//& "Jackson et al find values in the range of 0.085-0.089.", & - units="nondim", default=0.089) + units="nondim", default=0.089, do_not_log=just_read) call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & - units="nondim", default=50) + units="nondim", default=50, do_not_log=just_read) call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & - units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, unscaled=kappa_0_unscaled) + units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, & + unscaled=kappa_0_unscaled, do_not_log=just_read) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & - units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_T, do_not_log=just_read) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& "Richardson number in the kappa source term in the "//& - "Jackson et al. scheme.", units="nondim", default=-0.97) + "Jackson et al. scheme.", units="nondim", default=-0.97, do_not_log=just_read) call get_param(param_file, mdl, "TKE_N_DECAY_CONST", CS%C_N, & "The coefficient for the decay of TKE due to "//& "stratification (i.e. proportional to N*tke). "//& "The values found by Jackson et al. are 0.24-0.28.", & - units="nondim", default=0.24) + units="nondim", default=0.24, do_not_log=just_read) ! call get_param(param_file, mdl, "LAYER_KAPPA_STAGGER", CS%layer_stagger, & -! default=.false.) +! default=.false., do_not_log=just_read) call get_param(param_file, mdl, "TKE_SHEAR_DECAY_CONST", CS%C_S, & "The coefficient for the decay of TKE due to shear (i.e. "//& "proportional to |S|*tke). The values found by Jackson "//& - "et al. are 0.14-0.12.", units="nondim", default=0.14) + "et al. are 0.14-0.12.", units="nondim", default=0.14, do_not_log=just_read) call get_param(param_file, mdl, "KAPPA_BUOY_SCALE_COEF", CS%lambda, & "The coefficient for the buoyancy length scale in the "//& "kappa equation. The values found by Jackson et al. are "//& - "in the range of 0.81-0.86.", units="nondim", default=0.82) + "in the range of 0.81-0.86.", units="nondim", default=0.82, do_not_log=just_read) call get_param(param_file, mdl, "KAPPA_N_OVER_S_SCALE_COEF2", CS%lambda2_N_S, & "The square of the ratio of the coefficients of the "//& "buoyancy and shear scales in the diffusivity equation, "//& "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & - units="nondim", default=0.0) + units="nondim", default=0.0, do_not_log=just_read) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & "The fractional error in kappa that is tolerated. "//& "Iteration stops when changes between subsequent "//& "iterations are smaller than this everywhere in a "//& "column. The peak diffusivities usually converge most "//& "rapidly, and have much smaller errors than this.", & - units="nondim", default=0.1) + units="nondim", default=0.1, do_not_log=just_read) call get_param(param_file, mdl, "TKE_BACKGROUND", CS%TKE_bg, & "A background level of TKE used in the first iteration "//& "of the kappa equation. TKE_BACKGROUND could be 0.", & @@ -2070,40 +2075,40 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "massive layers in this calculation. The default is "//& "true and I can think of no good reason why it should "//& "be false. This is only used if USE_JACKSON_PARAM is true.", & - default=.true.) + default=.true., do_not_log=just_read) call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & "The maximum number of iterations that may be used to "//& "estimate the time-averaged diffusivity.", units="nondim", & - default=13) + default=13, do_not_log=just_read) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & - "The turbulent Prandtl number applied to shear "//& - "instability.", units="nondim", default=1.0, do_not_log=.true.) + "The turbulent Prandtl number applied to shear instability.", & + units="nondim", default=1.0, do_not_log=.true.) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & - "A negligibly small velocity magnitude below which velocity "//& - "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) + "A negligibly small velocity magnitude below which velocity 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, do_not_log=just_read) 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") + default=10.0, units="nondim", do_not_log=just_read) call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& "Caution: this option is _very_ verbose and should only "//& "be used in single-column mode!", & - default=.false., debuggingParam=.true.) + default=.false., debuggingParam=.true., do_not_log=just_read) call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & "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 > 1 m.", default=.false.) + "The bug causes undercorrections when dz > 1 m.", default=.false., do_not_log=just_read) 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=.false.) + default=.false., do_not_log=just_read) ! 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) @@ -2112,8 +2117,8 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = 1 if (GV%nkml>0) then call get_param(param_file, mdl, "KAPPA_SHEAR_MERGE_ML",merge_mixedlayer, & - "If true, combine the mixed layers together before "//& - "solving the kappa-shear equations.", default=.true.) + "If true, combine the mixed layers together before solving the "//& + "kappa-shear equations.", default=.true., do_not_log=just_read) if (merge_mixedlayer) CS%nkml = GV%nkml endif diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 56d16a8613..f8a96c894b 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -109,10 +109,8 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) if (.not. associated(CS)) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") - if (CS%regularize_surface_layers) & - call pass_var(h, G%Domain, clock=id_clock_pass) - if (CS%regularize_surface_layers) then + call pass_var(h, G%Domain, clock=id_clock_pass) call regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) endif @@ -891,6 +889,7 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. logical :: use_temperature logical :: default_2018_answers + logical :: just_read integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -904,38 +903,42 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) CS%Time => Time ! Set default, read and log parameters - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, "", all_default=.not.CS%regularize_surface_layers) call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & "If defined, vertically restructure the near-surface "//& "layers when they have too much lateral variations to "//& "allow for sensible lateral barotropic transports.", & default=.false.) + just_read = .not.CS%regularize_surface_layers if (CS%regularize_surface_layers) then call get_param(param_file, mdl, "REGULARIZE_SURFACE_DETRAIN", CS%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.", default=.true.) - call get_param(param_file, mdl, "REG_SFC_DENSE_MATCH_TOLERANCE", CS%density_match_tol, & + "REGULARIZE_SURFACE_LAYERS is true.", default=.true., do_not_log=just_read) + 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) + "default of 0.6 gives 20% overlaps in density", & + units="nondim", default=0.6, do_not_log=just_read) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) + default=.false., do_not_log=just_read) 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) + "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, do_not_log=just_read) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & - "The minimum mixed layer depth if the mixed layer depth "//& - "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H) + "The minimum mixed layer depth if the mixed layer depth is determined "//& + "dynamically.", units="m", default=0.0, scale=GV%m_to_H, do_not_log=just_read) call get_param(param_file, mdl, "REG_SFC_DEFICIT_TOLERANCE", CS%h_def_tol1, & "The value of the relative thickness deficit at which "//& "to start modifying the layer structure when "//& "REGULARIZE_SURFACE_LAYERS is true.", units="nondim", & - default=0.5) + default=0.5, do_not_log=just_read) CS%h_def_tol2 = 0.2 + 0.8*CS%h_def_tol1 CS%h_def_tol3 = 0.3 + 0.7*CS%h_def_tol1 CS%h_def_tol4 = 0.5 + 0.5*CS%h_def_tol1 @@ -943,12 +946,14 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) ! if (.not. CS%debug) & ! call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debug, & -! "If true, monitor conservation and extrema.", default=.false.) +! "If true, monitor conservation and extrema.", default=.false., do_not_log=just_read) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", CS%allow_clocks_in_omp_loops, & "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & - default=.true.) + default=.true., do_not_log=just_read) + + if (.not.CS%regularize_surface_layers) return CS%id_def_rat = register_diag_field('ocean_model', 'deficit_ratio', diag%axesT1, & Time, 'Max face thickness deficit ratio', 'nondim') diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 59131bf776..5868d60b46 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -382,7 +382,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real, dimension(SZIB_(G)) :: & hlst, & ! Work variable [H L2 ~> m3 or kg]. Ihnew, & ! Work variable [H-1 L-2 ~> m-3 or kg-1]. - CFL ! A nondimensional work variable [nondim]. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost @@ -757,7 +757,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real, dimension(SZIB_(G)) :: & hlst, & ! Work variable [H L2 ~> m3 or kg]. Ihnew, & ! Work variable [H-1 L-2 ~> m-3 or kg-1]. - CFL ! A nondimensional work variable. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost From e18f87059fbc626f4e4f9257f2b1b3368af6db0c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 16 Jun 2020 16:16:17 -0800 Subject: [PATCH 088/256] +partial fix for #1130 - Add OBC code to TKE_BBL calculation. - Might change answers. --- src/core/MOM.F90 | 4 +- .../vertical/MOM_diabatic_driver.F90 | 6 ++- .../vertical/MOM_set_diffusivity.F90 | 44 +++++++++++++++++-- 3 files changed, 47 insertions(+), 7 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a044f95893..a236a36608 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1265,8 +1265,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, & + Time_end_thermo, G, GV, US, CS%diabatic_CSp, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0bd3138670..4d6f24f6f9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -53,6 +53,7 @@ module MOM_diabatic_driver use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln use MOM_opacity, only : opacity_init, opacity_end, opacity_CS use MOM_opacity, only : absorbRemainingSW, optics_type, optics_nbands +use MOM_open_boundary, only : ocean_OBC_type use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end @@ -255,7 +256,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, US, CS, WAVES) + G, GV, US, CS, OBC, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -275,6 +276,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables @@ -321,7 +323,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp) + call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) call cpu_clock_end(id_clock_set_diffusivity) ! Frazil formation keeps the temperature above the freezing point. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9d03b11f7b..98cc289030 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -30,6 +30,8 @@ module MOM_set_diffusivity use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d @@ -1636,7 +1638,7 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) +subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) 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 @@ -1650,6 +1652,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! This subroutine calculates several properties related to bottom ! boundary layer turbulence. @@ -1674,6 +1677,15 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz + logical :: local_open_u_BC, local_open_v_BC + + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(CS)) call MOM_error(FATAL,"set_BBL_TKE: "//& @@ -1708,7 +1720,20 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + hvel = GV%H_to_Z*h(i,j,k) + else + hvel = GV%H_to_Z*h(i,j+1,k) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + endif + if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then vhtot(i) = vhtot(i) + (visc%bbl_thick_v(i,J) - htot(i))*v(i,J,k) htot(i) = visc%bbl_thick_v(i,J) @@ -1737,7 +1762,20 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + hvel = GV%H_to_Z*h(i,j,k) + else + hvel = GV%H_to_Z*h(i+1,j,k) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + endif + if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then uhtot(I) = uhtot(I) + (visc%bbl_thick_u(I,j) - htot(I))*u(I,j,k) htot(I) = visc%bbl_thick_u(I,j) From 3b15f269e4c942191c0b904ed470dac6e6e825b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 17 Jun 2020 16:31:12 -0400 Subject: [PATCH 089/256] +Fix documentation problems leading to warnings Corrected units documentation of MSTAR, set the default value of S_REF in adjustment_initialize_temperature_salinity consistently with other places, and added a register_diag field for 'h_ML' ePBL_init as a duplicate alias for the 'ePBL_h_ML' diagnostic. All answers are bitwise identical, but there are changes in the MOM_parameter_doc files and available_diags. --- src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 | 2 +- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 6 +++++- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 2 +- src/user/adjustment_initialization.F90 | 4 ++-- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 021ed4a26f..079655f787 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3438,7 +3438,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "BULKMIXEDLAYER is true.", units="nondim", default=2) 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) + "input to the mixed layer.", units="nondim", default=1.2) call get_param(param_file, mdl, "NSTAR", CS%nstar, & "The portion of the buoyant potential energy imparted by "//& "surface fluxes that is available to drive entrainment "//& diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index c27270c432..32c2797394 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -191,7 +191,7 @@ module MOM_energetic_PBL 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] !>@{ Diagnostic IDs - integer :: id_ML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 + integer :: id_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1 integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 @@ -515,6 +515,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (write_diags) then if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) @@ -2347,6 +2348,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) 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') + ! This is an alias for the same variable as ePBL_h_ML + CS%id_hML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & + Time, 'Surface mixed layer depth based on active turbulence', 'm', conversion=US%Z_to_m) CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & 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, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index f2d4484c78..b754e7cfc3 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1982,7 +1982,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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) + "input to the mixed layer.", units="nondim", default=1.2) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & "The ratio of the natural Ekman depth to the TKE decay scale.", & units="nondim", default=2.5) diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 0b9d4409f8..6dde9c68ef 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -220,8 +220,8 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, G, GV, param_file just_read = .false. ; if (present(just_read_params)) just_read = just_read_params ! Parameters used by main model initialization - call get_param(param_file, mdl,"S_REF",S_ref,'Reference salinity', units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='C', & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range', units='1e-3', & From f11d301679eb7411afaa02b9a24be130183d77c1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 22:10:47 +0000 Subject: [PATCH 090/256] Corrected docs for FMS_coupler.F90 - @Hallberg-NOAA pointed out some obviously wrong documentation of arguments. --- config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 index 6e0d84da86..f3d63dd061 100644 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -13,7 +13,7 @@ subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb is, ie, js, je, conversion) real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values integer, intent(in) :: ilb, jlb !< Lower bounds - type(coupler_2d_bc_type), intent(in) :: BC_struc !< A number that every element is multiplied by + type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted integer, intent(in) :: BC_index !< The boundary condition number being extracted integer, intent(in) :: BC_element !< The element of the boundary condition being extracted integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled @@ -26,8 +26,8 @@ subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC integer, intent(in) :: ilb, jlb !< Lower bounds type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded - integer, intent(in) :: BC_index !< The boundary condition number being extracted - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted + integer, intent(in) :: BC_index !< The boundary condition number being set + integer, intent(in) :: BC_element !< The element of the boundary condition being set integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled real, optional, intent(in) :: conversion !< A number that every element is multiplied by end subroutine set_coupler_values From ed74a88fef1c5ca4781970ab0132e1b91b97bc4f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 16:46:47 +0000 Subject: [PATCH 091/256] Correct search path or nolib builds in gitlab pipeline - After added config_src/external we need to include this in the search path for builds. I'd forgotten about the nolib build test we do via gitlab. --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5a05694fef..02c6d15877 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -60,7 +60,7 @@ gnu:ocean-only-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric} ../../../src ../../MOM6-examples/src/FMS + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric,ext*} ../../../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) @@ -73,7 +73,7 @@ gnu:ice-ocean-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic,ext*} ../../../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 1a567947887e4a89e85088bb626f9236a3a16b41 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 18:57:09 +0000 Subject: [PATCH 092/256] Minor adjustments to .testing/Makefile - Fixed left over "nv" file (from building on gaea login nodes) - Avoid invoking python if input files already exist - Increased length of traceback displayed if model crashes - Used $(MAKE) in place of make to avoid "-j1" warnings from submake - Removed left over commented commands in .restart targets - Added some comments about config.mk to README.md --- .testing/Makefile | 16 +++++++--------- .testing/README.md | 7 +++++++ .testing/tc4/Makefile | 2 +- 3 files changed, 15 insertions(+), 10 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index d38189667b..29785af0fe 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -114,7 +114,7 @@ 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 - make -C $(@D) $(MOMFLAGS) $(@F) + $(MAKE) -C $(@D) $(MOMFLAGS) $(@F) build/%/Makefile: build/%/path_names cp $(MKMF_TEMPLATE) $(@D) @@ -153,7 +153,7 @@ $(TARGET_CODEBASE): $(FMS)/lib/libfms.a: $(FMS)/build/Makefile mkdir -p $(FMS)/lib - cd $(FMS)/build && make NETCDF=3 DEBUG=1 ../lib/libfms.a + cd $(FMS)/build && $(MAKE) NETCDF=3 DEBUG=1 ../lib/libfms.a $(FMS)/build/Makefile: $(FMS)/build/path_names cp $(MKMF_TEMPLATE) $(@D) @@ -250,8 +250,6 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # Restart tests only compare the final stat record .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/$*; \ @@ -271,7 +269,7 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # $(1): Environment variables ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) -else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$?), 0) +else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$? ; rm -f nv), 0) MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) else MPIRUN_CMD=$(1) $(MPIRUN) @@ -291,15 +289,15 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) cp -rL $$*/* $$(@D) - cd $$(@D) && if [ -f Makefile ]; then make; fi + 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 ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ rm ocean.stats chksum_diag ; \ echo -e "${FAIL}: $$*.$(1) failed at runtime." \ ) @@ -337,7 +335,7 @@ 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 + cd work/$*/restart && if [ -f Makefile ]; then $(MAKE); fi mkdir -p $(@D)/RESTART # Generate the half-period input namelist # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml diff --git a/.testing/README.md b/.testing/README.md index 5cd190ef25..abad08ada8 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -217,3 +217,10 @@ use `srun` (such as on GFDL's gaea HPC): ``` make MPIRUN=srun test ``` + +For convenience you can provide some macro in the file `config.mk`. For example, on +gaea, to be able to run `make test -s -j` you will find putting the line +``` +MPIRUN = srun -mblock --exclusive +``` +in `config.mk` very useful. diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile index cea78bf3bd..c332bbd7e6 100644 --- a/.testing/tc4/Makefile +++ b/.testing/tc4/Makefile @@ -1,3 +1,3 @@ -all: +ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc: python build_grid.py python build_data.py From fb40115c8cb0f4ac116da79e60d474fb6feb1495 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 20:21:04 +0000 Subject: [PATCH 093/256] Changed strategy for handling fms_platform.h - Providing a dummy fms_platform.h which is included by the real generic_tracers_util.F90 causes problems when compiling without libraries since FMS modules need the real fms_platform.h. This removes the fake file and avoids use of CPP macros provided by the .h file. - MOM_generic_tracers.F90 no longer includes fms_platform.h but defines the one macro that was being used in the same way the .h file was doing it. --- config_src/external/GFDL_ocean_BGC/fms_platform.h | 3 --- .../external/GFDL_ocean_BGC/generic_tracer_utils.F90 | 5 ++--- src/tracer/MOM_generic_tracer.F90 | 9 ++++++++- 3 files changed, 10 insertions(+), 7 deletions(-) delete mode 100644 config_src/external/GFDL_ocean_BGC/fms_platform.h diff --git a/config_src/external/GFDL_ocean_BGC/fms_platform.h b/config_src/external/GFDL_ocean_BGC/fms_platform.h deleted file mode 100644 index 32faf4aa8c..0000000000 --- a/config_src/external/GFDL_ocean_BGC/fms_platform.h +++ /dev/null @@ -1,3 +0,0 @@ -#define _ALLOCATED(arg) allocated(arg) -#define _ALLOCATABLE allocatable -#define _NULL diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index fbff35aa63..6937ef4710 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -3,7 +3,6 @@ !! for adding, allocating memory, and record keeping of individual generic !! tracers irrespective of their physical/chemical nature. module g_tracer_utils -#include use coupler_types_mod, only: coupler_2d_bc_type use time_manager_mod, only : time_type @@ -20,7 +19,7 @@ module g_tracer_utils !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. real, pointer, dimension(:,:,:,:) :: field => NULL() !> Tracer concentration in river runoff - real, _ALLOCATABLE, dimension(:,:) :: trunoff _NULL + real, allocatable, dimension(:,:) :: trunoff logical :: requires_restart = .true. !< Unknown !> Tracer source: filename, type, var name, units, record, gridfile character(len=fm_string_len) :: src_file, src_var_name, src_var_unit, src_var_gridspec @@ -264,7 +263,7 @@ end subroutine g_tracer_get_next !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field !! for a tracer node.This is ported from GOLD (vertdiff) and simplified !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting - !! tracer concentrationhas units of mol/Kg + !! tracer concentration has units of mol/Kg subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) type(g_tracer_type), pointer :: g_tracer !> Layer thickness before entrainment, in m or kg m-2. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index b031488e23..7d2310b42f 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -5,7 +5,14 @@ module MOM_generic_tracer #include -#include +! The following macro is usually defined in but since MOM6 should not directly +! include files from FMS we replicate the macro lines here: +#ifdef NO_F2000 +#define _ALLOCATED associated +#else +#define _ALLOCATED allocated +#endif + ! ### These imports should not reach into FMS directly ### use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE From 20d2b383c431dbeca4226edd680bb945dc73d1f6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jun 2020 18:15:58 -0400 Subject: [PATCH 094/256] *Fix frazil restarts Corrected a bug which causes frazil to be zeroed out during restarts. This will change answers in long coupled or ice-ocean runs, but not in the short MOM6-examples test suite. This bug was introduced to MOM6 on April 30, 2020 with PR#1102. The answers and documentation files in MOM6-examples are unchanged. This PR was tested for restarts, but it used the Baltic test case and happened to use a day where the frazil was zero everywhere in this limited test case. Other test cases should be expected to change answers with every restart, leading to a small net long-term heat gain in the coupled system. --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2ff06b85f0..50231fc96b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2665,7 +2665,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) /= & From a3c1772ba28e0207c542a101dadf2992b70ca048 Mon Sep 17 00:00:00 2001 From: Santha Akella <18061653+sanAkel@users.noreply.github.com> Date: Thu, 18 Jun 2020 18:44:19 -0400 Subject: [PATCH 095/256] Additions from GMAO (I): (#1134) * Additions from GMAO (I): a. CMakeLists and .github/to be able to use CMake, b. MOM_surface_forcing_gfdl.F90 has an optional argument in surface_forcing_init for setting wind_stagger from coupler; if it is not present, default behavior is preserved, c. ocean_model_MOM.F90 has added hooks to give a hangle to the grid: get_ocean_grid, currents: ocean_model_get_UV_surf, few additional 2D fields in ocean_model_data2D_get, and optional input argument wind_stagger in ocean_model_init that relates to b. * remove trailing space in MOM_surface_forcing_gfdl.F90 for travis CI * Thank you, @adcroft, for the review https://github.com/NOAA-GFDL/MOM6/pull/1134 (i) Remove CMakeLists.txt and .github/CODEOWNERS, (ii) Removed indentation that happened for some reason! in MOM_surface_forcing_gfdl.F90 and ocean_model_MOM.F90, (iii) arguments in ocean_model_MOM.F90: get_ocean_grid are documented. (It was a copy paste from https://github.com/NOAA-GFDL/MOM6/blob/505be4baf760acb0cb6d05d63f5102c6e2b8b000/config_src/nuopc_driver/mom_ocean_model_nuopc.F90#L1066 which is also undocumented.) * remove trailing space in ocean_model_MOM.F90: get_ocean_grid Co-authored-by: Santha Akella --- .../MOM_surface_forcing_gfdl.F90 | 37 ++++--- config_src/coupled_driver/ocean_model_MOM.F90 | 97 ++++++++++++++++++- 2 files changed, 120 insertions(+), 14 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 7d2814da93..7bcb7f1cf1 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -16,7 +16,7 @@ module MOM_surface_forcing_gfdl use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type @@ -1231,7 +1231,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart !> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1240,6 +1240,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are + !! being provided in calls to update_ocean_model ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. @@ -1347,15 +1349,28 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "the ocean dynamics. The actual net mass source may differ "//& "due to internal corrections.", default=.false.) - call get_param(param_file, mdl, "WIND_STAGGER", stagger, & - "A case-insensitive character string to indicate the "//& - "staggering of the input wind stress field. Valid "//& - "values are 'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID - elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE - elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE - else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & - trim(stagger)//" is invalid.") ; endif + if (present(wind_stagger)) then + if (wind_stagger == AGRID) then ; stagger = 'AGRID' + elseif (wind_stagger == BGRID_NE) then ; stagger = 'BGRID_NE' + elseif (wind_stagger == CGRID_NE) then ; stagger = 'CGRID_NE' + else ; stagger = 'UNKNOWN' ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & + trim(stagger)// "is invalid."); endif + call log_param(param_file, mdl, "WIND_STAGGER", stagger, & + "The staggering of the input wind stress field "//& + "from the coupler that is actually used.") + CS%wind_stagger = wind_stagger + else + call get_param(param_file, mdl, "WIND_STAGGER", stagger, & + "A case-insensitive character string to indicate the "//& + "staggering of the input wind stress field. Valid "//& + "values are 'A', 'B', or 'C'.", default="C") + if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID + elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE + elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE + else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & + trim(stagger)//" is invalid.") ; endif + endif + call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 05759cb7b8..082099158c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -77,6 +77,8 @@ module ocean_model_mod public ice_ocn_bnd_type_chksum public ocean_public_type_chksum public ocean_model_data_get +public get_ocean_grid +public ocean_model_get_UV_surf !> This interface extracts a named scalar field or array from the ocean surface or public type interface ocean_model_data_get @@ -222,7 +224,7 @@ module ocean_model_mod !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -232,6 +234,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) !! contain all information about the ocean's interior state. type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are + !! being provided in calls to update_ocean_model type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -354,8 +358,13 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., & gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) - call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & - OS%forcing_CSp) + if (present(wind_stagger)) then + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp, wind_stagger) + else + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp) + endif if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & @@ -1045,6 +1054,16 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET case('btfHeat') array2D(isc:,jsc:) = 0 + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case('s_surf') + array2D(isc:,jsc:) = Ocean%s_surf(isc:,jsc:) + case('sea_lev') + array2D(isc:,jsc:) = Ocean%sea_lev(isc:,jsc:) + case('frazil') + array2D(isc:,jsc:) = Ocean%frazil(isc:,jsc:) case default call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) end select @@ -1096,4 +1115,76 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) end subroutine ocean_public_type_chksum +!> This subroutine gives a handle to the grid from ocean state +subroutine get_ocean_grid(OS, Gridp) + ! Obtain the ocean grid. + type(ocean_state_type) :: OS !< A structure containing the + !! internal ocean state + type(ocean_grid_type) , pointer :: Gridp !< The ocean's grid structure + + Gridp => OS%grid + return +end subroutine get_ocean_grid + +!> This subroutine extracts a named (u- or v-) 2-D surface current from ocean internal state +subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) + + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + type(ocean_grid_type) , pointer :: G !< The ocean's grid structure + type(surface), pointer :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0 + integer :: is, ie, js, je + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + G => OS%grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call mpp_get_compute_domain(Ocean%Domain, isc_bnd, iec_bnd, & + jsc_bnd, jec_bnd) + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + sfc_state => OS%sfc_state + + select case(name) + case('ua') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) + enddo ; enddo + case('va') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) + enddo ; enddo + case('ub') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) + enddo ; enddo + case('vb') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) + enddo ; enddo + case default + call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) + end select + +end subroutine ocean_model_get_UV_surf + end module ocean_model_mod From 14e944e04c3d444cbd50ffd196ed03a8b6ac7b85 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jun 2020 11:36:18 -0400 Subject: [PATCH 096/256] Fixed OpenMP directives in support of this PR --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 98cc289030..a82655ed2a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1703,10 +1703,8 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) cdrag_sqrt = sqrt(CS%cdrag) -!$OMP parallel default(none) shared(cdrag_sqrt,is,ie,js,je,nz,visc,CS,G,GV,US,vstar,h,v, & -!$OMP v2_bbl,u) & -!$OMP private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) -!$OMP do + !$OMP parallel default(shared) private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) + !$OMP do do J=js-1,je ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and @@ -1752,7 +1750,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) v2_bbl(i,J) = 0.0 endif ; enddo enddo -!$OMP do + !$OMP do do j=js,je do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 @@ -1807,7 +1805,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j)) enddo enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_BBL_TKE From 7c6041ada7ec0e57ddb3f5b71ee37263d70c95e7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 17:33:07 +0000 Subject: [PATCH 097/256] Replaced copies of GSW files with links - We always intended to use links so that we were not maintaining code that did not belong to us. `listpaths` used to not work as expected so Niki had placed copies here when adding TEOS10. Using links also avoids any license conflicts. --- .../gsw_chem_potential_water_t_exact.f90 | 83 +- .../TEOS10/gsw_ct_freezing_exact.f90 | 44 +- .../TEOS10/gsw_ct_freezing_poly.f90 | 54 +- .../TEOS10/gsw_ct_from_pt.f90 | 53 +- .../TEOS10/gsw_ct_from_t.f90 | 33 +- .../TEOS10/gsw_entropy_part.f90 | 63 +- .../TEOS10/gsw_entropy_part_zerop.f90 | 45 +- src/equation_of_state/TEOS10/gsw_gibbs.f90 | 318 +--- .../TEOS10/gsw_gibbs_ice.f90 | 131 +- .../TEOS10/gsw_gibbs_pt0_pt0.f90 | 48 +- .../gsw_mod_freezing_poly_coefficients.f90 | 64 +- .../TEOS10/gsw_mod_gibbs_ice_coefficients.f90 | 31 +- .../TEOS10/gsw_mod_kinds.f90 | 17 +- .../TEOS10/gsw_mod_specvol_coefficients.f90 | 314 +--- .../TEOS10/gsw_mod_teos10_constants.f90 | 72 +- .../TEOS10/gsw_mod_toolbox.f90 | 1494 +---------------- .../TEOS10/gsw_pt0_from_t.f90 | 60 +- .../TEOS10/gsw_pt_from_ct.f90 | 73 +- .../TEOS10/gsw_pt_from_t.f90 | 62 +- src/equation_of_state/TEOS10/gsw_rho.f90 | 37 +- .../TEOS10/gsw_rho_first_derivatives.f90 | 111 +- .../TEOS10/gsw_rho_second_derivatives.f90 | 79 +- .../TEOS10/gsw_sp_from_sr.f90 | 31 +- src/equation_of_state/TEOS10/gsw_specvol.f90 | 53 +- .../TEOS10/gsw_specvol_first_derivatives.f90 | 105 +- .../TEOS10/gsw_specvol_second_derivatives.f90 | 132 +- .../TEOS10/gsw_sr_from_sp.f90 | 31 +- ...w_t_deriv_chem_potential_water_t_exact.f90 | 89 +- .../TEOS10/gsw_t_freezing_exact.f90 | 72 +- .../TEOS10/gsw_t_freezing_poly.f90 | 79 +- .../TEOS10/gsw_t_from_ct.f90 | 34 +- 31 files changed, 31 insertions(+), 3881 deletions(-) mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_kinds.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_from_ct.f90 diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 deleted file mode 100644 index ca1ac55956..0000000000 --- a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!========================================================================== -elemental function gsw_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the chemical potential of water in seawater. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_t_exact = chemical potential of water in seawater -! [ J/g ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_chem_potential_water_t_exact - -real (r8) :: g03_g, g08_g, g_sa_part, x, x2, y, z - -real (r8), parameter :: kg2g = 1e-3_r8 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03_g = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - -g08_g = x2*(1416.27648484197_r8 + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8)) - -g_sa_part = 8645.36753595126_r8 + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8) - -gsw_chem_potential_water_t_exact = kg2g*(g03_g + g08_g - 0.5_r8*x2*g_sa_part) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..7ce7ff9e1e --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 deleted file mode 100644 index 1627322dcd..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 +++ /dev/null @@ -1,43 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. The -! Conservative Temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_CT_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_t_freezing_exact -use gsw_mod_toolbox, only : gsw_ct_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_exact - -real (r8) :: t_freezing - -t_freezing = gsw_t_freezing_exact(sa,p,saturation_fraction) -gsw_ct_freezing_exact = gsw_ct_from_t(sa,t_freezing,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 new file mode 120000 index 0000000000..696fe5c425 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 deleted file mode 100644 index a6b8f08091..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. -! The error of this fit ranges between -5e-4 K and 6e-4 K when compared -! with the Conservative Temperature calculated from the exact in-situ -! freezing temperature which is found by a Newton-Raphson iteration of the -! equality of the chemical potentials of water in seawater and in ice. -! Note that the Conservative temperature freezing temperature can be found -! by this exact method using the function gsw_CT_freezing. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -! That is, the freezing temperature expressed in -! terms of Conservative Temperature (ITS-90). -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_poly - -real (r8) :: p_r, sa_r, x - -sa_r = sa*1e-2_r8 -x = sqrt(sa_r) -p_r = p*1e-4_r8 - -gsw_ct_freezing_poly = c0 & - + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) & - + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 & - + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) & - + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r))) - -! Adjust for the effects of dissolved air -gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* & - (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso)) - -return -end function diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 new file mode 120000 index 0000000000..84e6e12572 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 deleted file mode 100644 index c4a624ed37..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_pt (sa, pt) -!========================================================================== -! -! Calculates Conservative Temperature from potential temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! pt : potential temperature with [deg C] -! reference pressure of 0 dbar -! -! gsw_ct_from_pt : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt - -real (r8) :: gsw_ct_from_pt - -real (r8) :: pot_enthalpy, x2, x, y - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt*0.025_r8 ! normalize for F03 and F08 - -pot_enthalpy = 61.01362420681071_r8 + y*(168776.46138048015_r8 + & - y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + & - y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + & - (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + & - x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + & - y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + & - y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - & - 10.650848542359153_r8*y)*y)))) + & - x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + & - y*(248.39476522971285_r8 + (-3.871557904936333_r8 - & - 2.6268019854268356_r8*y)*y)) + & - x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + & - x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + & - y*(936.3206544460336_r8 + & - y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + & - (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y)))))) - -gsw_ct_from_pt = pot_enthalpy/gsw_cp0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 new file mode 120000 index 0000000000..d67d2df3e2 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_pt.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 deleted file mode 100644 index b2a0c9e354..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_t (sa, t, p) -!========================================================================== -! -! Calculates Conservative Temperature from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_ct_from_t : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_ct_from_t - -real (r8) :: pt0 - -pt0 = gsw_pt0_from_t(sa,t,p) -gsw_ct_from_t = gsw_ct_from_pt(sa,pt0) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 new file mode 120000 index 0000000000..6f917027b3 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 deleted file mode 100644 index 70fcd11255..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part (sa, t, p) -!========================================================================== -! -! entropy minus the terms that are a function of only SA -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_entropy_part : entropy part -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_entropy_part - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03 = z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - -g08 = x2*(z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*( x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - -gsw_entropy_part = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 new file mode 120000 index 0000000000..0160db551f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 deleted file mode 100644 index 2156b71c4e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part_zerop (sa, pt0) -!========================================================================== -! -! entropy part evaluated at the sea surface -! -! sa : Absolute Salinity [g/kg] -! pt0 : insitu temperature [deg C] -! -! gsw_entropy_part_zerop : entropy part at the sea surface -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_entropy_part_zerop - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = y*(-24715.571866078_r8 + y*(2210.2236124548363_r8 + & - y*(-592.743745734632_r8 + y*(290.12956292128547_r8 + & - y*(-113.90630790850321_r8 + y*21.35571525415769_r8))))) - -g08 = x2*(x*(x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y)))) + & - y*(-86.1329351956084_r8 + y*(-30.0682112585625_r8 + y*3.50240264723578_r8))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y))))) - -gsw_entropy_part_zerop = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 new file mode 120000 index 0000000000..678bce8822 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part_zerop.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 deleted file mode 100644 index 59f7d221ac..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs.f90 +++ /dev/null @@ -1,317 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs (ns, nt, np, sa, t, p) -!========================================================================== -! -! seawater specific Gibbs free energy and derivatives up to order 2 -! -! ns : order of s derivative -! nt : order of t derivative -! np : order of p derivative -! sa : Absolute Salinity [g/kg] -! t : temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_gibbs : specific Gibbs energy or its derivative -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: ns, nt, np -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_gibbs - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -if(ns.eq.0 .and. nt.eq.0 .and. np.eq.0) then - - g03 = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - - g08 = x2*(1416.27648484197_r8 + z*(-3310.49154044839_r8 + & - z*(384.794152978599_r8 + z*(-96.5324320107458_r8 + (15.8408172766824_r8 - 2.62480156590992_r8*z)*z))) + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - y*(880.031352997204_r8 + y*(-225.267649263401_r8 + & - y*(91.4260447751259_r8 + y*(-21.6603240875311_r8 + 2.13016970847183_r8*y) + & - z*(-297.728741987187_r8 + (74.726141138756_r8 - 36.4872919001588_r8*z)*z)) + & - z*(694.244814133268_r8 + z*(-204.889641964903_r8 + (113.561697840594_r8 - 11.1282734326413_r8*z)*z))) + & - z*(-860.764303783977_r8 + z*(337.409530269367_r8 + & - z*(-178.314556207638_r8 + (44.2040358308_r8 - 7.92001547211682_r8*z)*z)))))) - - if(sa.gt.0.0_r8) & - g08 = g08 + x2*(5812.81456626732_r8 + 851.226734946706_r8*y)*log(x) - - gsw_gibbs = g03 + g08 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 8645.36753595126_r8 + z*(-6620.98308089678_r8 + & - z*(769.588305957198_r8 + z*(-193.0648640214916_r8 + (31.6816345533648_r8 - 5.24960313181984_r8*z)*z))) + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-450.535298526802_r8 + & - y*(182.8520895502518_r8 + y*(-43.3206481750622_r8 + 4.26033941694366_r8*y) + & - z*(-595.457483974374_r8 + (149.452282277512_r8 - 72.9745838003176_r8*z)*z)) + & - z*(1388.489628266536_r8 + z*(-409.779283929806_r8 + (227.123395681188_r8 - 22.2565468652826_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) then - g08 = g08 + (11625.62913253464_r8 + 1702.453469893412_r8*y)*log(x) - else - g08 = 0.0_r8 - endif - - gsw_gibbs = 0.5*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.0) then - - g03 = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - - g08 = x2*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) g08 = g08 + 851.226734946706_r8*x2*log(x) - - gsw_gibbs = (g03 + g08)*0.025_r8 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.1) then - - g03 = 100015.695367145_r8 + z*(-5089.1530840726_r8 + & - z*(853.5533353388611_r8 + z*(-133.2587017014444_r8 + (21.0131554401542_r8 - 3.278571068826234_r8*z)*z))) + & - y*(-270.983805184062_r8 + z*(1552.307223226202_r8 + & - z*(-589.53765264366_r8 + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(1455.0364540468_r8 + z*(-1513.116771538718_r8 + & - z*(820.438986970584_r8 + z*(-222.2416255268872_r8 + 21.72103359585985_r8*z))) + & - y*(-672.50778314507_r8 + z*(998.720781638304_r8 + & - z*(-718.6359919632359_r8 + (195.2050074375488_r8 - 8.31535531044525_r8*z)*z)) + & - y*(397.968445406972_r8 + z*(-603.630761243752_r8 + (456.589115201523_r8 - 105.4993508931208_r8*z)*z) + & - y*(-194.618310617595_r8 + y*(63.5113936641785_r8 - 9.63108119393062_r8*y + & - z*(-44.5794634280918_r8 + 24.511816254543362_r8*z)) + & - z*(241.04130980405_r8 + z*(-165.8169157020456_r8 + & - 25.92762672308884_r8*z))))))) - - g08 = x2*(-3310.49154044839_r8 + z*(769.588305957198_r8 + & - z*(-289.5972960322374_r8 + (63.3632691067296_r8 - 13.1240078295496_r8*z)*z)) + & - x*(199.459603073901_r8 + x*(-54.7919133532887_r8 + 36.0284195611086_r8*x - 22.6683558512829_r8*y + & - (-8.16387957824522_r8 - 90.52653359134831_r8*z)*z) + & - z*(-104.588181856267_r8 + (204.1334828179377_r8 - 13.65007729765128_r8*z)*z) + & - y*(-175.292041186547_r8 + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(383.058066002476_r8 + y*(-460.319931801257_r8 + 234.565187611355_r8*y) + & - z*(-108.3834525034224_r8 + 76.9195462169742_r8*z)))) + & - y*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - y*(-860.764303783977_r8 + y*(694.244814133268_r8 + & - y*(-297.728741987187_r8 + (149.452282277512_r8 - 109.46187570047641_r8*z)*z) + & - z*(-409.779283929806_r8 + (340.685093521782_r8 - 44.5130937305652_r8*z)*z)) + & - z*(674.819060538734_r8 + z*(-534.943668622914_r8 + (176.8161433232_r8 - 39.600077360584095_r8*z)*z))))) - - gsw_gibbs = (g03 + g08)*1e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.2 .and. np.eq.0) then - - g03 = -24715.571866078_r8 + z*(2910.0729080936_r8 + z* & - (-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(4420.4472249096725_r8 + z*(-4035.04669887042_r8 + & - z*(2996.162344914912_r8 + z*(-1437.2719839264719_r8 + (292.8075111563232_r8 - 9.978426372534301_r8*z)*z))) + & - y*(-1778.231237203896_r8 + z*(4775.621344883664_r8 + & - z*(-3621.784567462512_r8 + (1826.356460806092_r8 - 316.49805267936244_r8*z)*z)) + & - y*(1160.5182516851419_r8 + z*(-3892.3662123519_r8 + & - z*(2410.4130980405_r8 + z*(-1105.446104680304_r8 + 129.6381336154442_r8*z))) + & - y*(-569.531539542516_r8 + y*(128.13429152494615_r8 - 404.50541014508605_r8*z) + & - z*(1905.341809925355_r8 + z*(-668.691951421377_r8 + 245.11816254543362_r8*z)))))) - - g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-60.136422517125_r8 - 2761.9195908075417_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z))) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y) + & - z*(-3572.7449038462437_r8 + (896.713693665072_r8 - 437.84750280190565_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*0.000625_r8 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.1) then - - g08 = -6620.98308089678_r8 + z*(1539.176611914396_r8 + & - z*(-579.1945920644748_r8 + (126.7265382134592_r8 - 26.2480156590992_r8*z)*z)) + & - x*(598.378809221703_r8 + x*(-219.1676534131548_r8 + 180.142097805543_r8*x - 90.6734234051316_r8*y + & - (-32.65551831298088_r8 - 362.10613436539325_r8*z)*z) + & - z*(-313.764545568801_r8 + (612.4004484538132_r8 - 40.95023189295384_r8*z)*z) + & - y*(-525.876123559641_r8 + (499.15435668109143_r8 - 265.347579144861_r8*z)*z + & - y*(1149.174198007428_r8 + y*(-1380.9597954037708_r8 + 703.695562834065_r8*y) + & - z*(-325.1503575102672_r8 + 230.7586386509226_r8*z)))) + & - y*(1458.233059470092_r8 + z*(-1375.827611846244_r8 + & - z*(748.126026697488_r8 + z*(-253.255715088584_r8 + 70.4658803315449_r8*z))) + & - y*(-1721.528607567954_r8 + y*(1388.489628266536_r8 + & - y*(-595.457483974374_r8 + (298.904564555024_r8 - 218.92375140095282_r8*z)*z) + & - z*(-819.558567859612_r8 + (681.370187043564_r8 - 89.0261874611304_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = g08*gsw_sfac*0.5e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.1) then - - g03 = -270.983805184062_r8 + z*(1552.307223226202_r8 + z*(-589.53765264366_r8 + & - (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(2910.0729080936_r8 + z*(-3026.233543077436_r8 + & - z*(1640.877973941168_r8 + z*(-444.4832510537744_r8 + 43.4420671917197_r8*z))) + & - y*(-2017.52334943521_r8 + z*(2996.162344914912_r8 + & - z*(-2155.907975889708_r8 + (585.6150223126464_r8 - 24.946065931335752_r8*z)*z)) + & - y*(1591.873781627888_r8 + z*(-2414.523044975008_r8 + (1826.356460806092_r8 - 421.9974035724832_r8*z)*z) + & - y*(-973.091553087975_r8 + z*(1205.20654902025_r8 + z*(-829.084578510228_r8 + 129.6381336154442_r8*z)) + & - y*(381.06836198507096_r8 - 67.41756835751434_r8*y + z*(-267.4767805685508_r8 + 147.07089752726017_r8*z)))))) - - g08 = x2*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - x*(-175.292041186547_r8 - 22.6683558512829_r8*x + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(766.116132004952_r8 + y*(-1380.9597954037708_r8 + 938.26075044542_r8*y) + & - z*(-216.7669050068448_r8 + 153.8390924339484_r8*z))) + & - y*(-1721.528607567954_r8 + y*(2082.7344423998043_r8 + & - y*(-1190.914967948748_r8 + (597.809129110048_r8 - 437.84750280190565_r8*z)*z) + & - z*(-1229.337851789418_r8 + (1022.055280565346_r8 - 133.5392811916956_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*2.5e-10_r8 - -elseif(ns.eq.1 .and. nt.eq.1 .and. np.eq.0) then - - g08 = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + & - y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + & - y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + 25.56203650166196_r8*y) + & - z*(-2381.829935897496_r8 + (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + & - z*(-713.258224830552_r8 + (176.8161433232_r8 - 31.68006188846728_r8*z)*z)))) - - if(sa.gt.0_r8) g08 = g08 + 1702.453469893412_r8*log(x) - - gsw_gibbs = 0.5_r8*gsw_sfac*0.025_r8*g08 - -elseif(ns.eq.2 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 2.0_r8*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - 1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - 340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + & - 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) - - if (x.gt.0_r8) then - g08 = g08 + (-7296.43987145382_r8 + z*(598.378809221703_r8 + & - z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + & - z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(2.626801985426835_r8 + 703.695562834065_r8*z)))))/x + & - (11625.62913253464_r8 + 1702.453469893412_r8*y)/x2 - else - g08 = 0.0_r8 - end if - - gsw_gibbs = 0.25_r8*gsw_sfac*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.2) then - - g03 = -5089.1530840726_r8 + z*(1707.1066706777221_r8 + & - z*(-399.7761051043332_r8 + (84.0526217606168_r8 - 16.39285534413117_r8*z)*z)) + & - y*(1552.307223226202_r8 + z*(-1179.07530528732_r8 + (347.75583155301_r8 - 42.658016703665396_r8*z)*z) + & - y*(-1513.116771538718_r8 + z*(1640.877973941168_r8 + z*(-666.7248765806615_r8 + 86.8841343834394_r8*z)) + & - y*(998.720781638304_r8 + z*(-1437.2719839264719_r8 + (585.6150223126464_r8 - 33.261421241781_r8*z)*z) + & - y*(-603.630761243752_r8 + (913.178230403046_r8 - 316.49805267936244_r8*z)*z + & - y*(241.04130980405_r8 + y*(-44.5794634280918_r8 + 49.023632509086724_r8*z) + & - z*(-331.6338314040912_r8 + 77.78288016926652_r8*z)))))) - - g08 = x2*(769.588305957198_r8 + z*(-579.1945920644748_r8 + (190.08980732018878_r8 - 52.4960313181984_r8*z)*z) + & - x*(-104.588181856267_r8 + x*(-8.16387957824522_r8 - 181.05306718269662_r8*z) + & - (408.2669656358754_r8 - 40.95023189295384_r8*z)*z + & - y*(166.3847855603638_r8 - 176.898386096574_r8*z + y*(-108.3834525034224_r8 + 153.8390924339484_r8*z))) + & - y*(-687.913805923122_r8 + z*(748.126026697488_r8 + z*(-379.883572632876_r8 + 140.9317606630898_r8*z)) + & - y*(674.819060538734_r8 + z*(-1069.887337245828_r8 + (530.4484299696_r8 - 158.40030944233638_r8*z)*z) + & - y*(-409.779283929806_r8 + y*(149.452282277512_r8 - 218.92375140095282_r8*z) + & - (681.370187043564_r8 - 133.5392811916956_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*1e-16_r8 - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 new file mode 120000 index 0000000000..6bb64d98a7 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 deleted file mode 100644 index 0416a1eeaf..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 +++ /dev/null @@ -1,130 +0,0 @@ -! ========================================================================= -elemental function gsw_gibbs_ice (nt, np, t, p) -! ========================================================================= -! -! Ice specific Gibbs energy and derivatives up to order 2. -! -! nt = order of t derivative [ integers 0, 1 or 2 ] -! np = order of p derivative [ integers 0, 1 or 2 ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! -! gibbs_ice = Specific Gibbs energy of ice or its derivatives. -! The Gibbs energy (when nt = np = 0) has units of: [ J/kg ] -! The temperature derivatives are output in units of: -! [ (J/kg) (K)^(-nt) ] -! The pressure derivatives are output in units of: -! [ (J/kg) (Pa)^(-np) ] -! The mixed derivatives are output in units of: -! [ (J/kg) (K)^(-nt) (Pa)^(-np) ] -! Note. The derivatives are taken with respect to pressure in Pa, not -! withstanding that the pressure input into this routine is in dbar. -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_t0, db2pa - -use gsw_mod_gibbs_ice_coefficients - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: nt, np -real (r8), intent(in) :: t, p - -real (r8) :: gsw_gibbs_ice - -real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt -complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2 - -real (r8), parameter :: s0 = -3.32733756492168e3_r8 - -tau = (t + gsw_t0)*rec_tt - -dzi = db2pa*p*rec_pt - -if (nt.eq.0 .and. np.eq.0) then - - tau_t1 = tau/t1 - sqtau_t1 = tau_t1*tau_t1 - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi))) - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) & - + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) & - + r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0 - tt*(s0*tau - real(g)) - -elseif (nt.eq.1 .and. np.eq.0) then - - tau_t1 = tau/t1 - tau_t2 = tau/t2 - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) & - + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = -s0 + real(g) - -elseif (nt.eq.0 .and. np.eq.1) then - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi))) - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0p + tt*real(g) - -elseif (nt.eq.1 .and. np.eq.1) then - - tau_t2 = tau/t2 - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = real(g) - -elseif (nt.eq.2 .and. np.eq.0) then - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) & - + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2) - - gsw_gibbs_ice = rec_tt*real(g) - -elseif (nt.eq.0 .and. np.eq.2) then - - sqrec_pt = rec_pt*rec_pt - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi)) - - r2pp = 2.0_r8*r22*sqrec_pt - - g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0pp + tt*real(g) - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 new file mode 120000 index 0000000000..9d1d06c481 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_ice.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 deleted file mode 100644 index 6e8bcfc779..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs_pt0_pt0 (sa, pt0) -!========================================================================== -! -! gibbs_tt at (sa,pt,0) -! -! sa : Absolute Salinity [g/kg] -! pt0 : potential temperature [deg C] -! -! gsw_gibbs_pt0_pt0 : gibbs_tt at (sa,pt,0) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_gibbs_pt0_pt0 - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = -24715.571866078_r8 + & - y*(4420.4472249096725_r8 + & - y*(-1778.231237203896_r8 + & - y*(1160.5182516851419_r8 + & - y*(-569.531539542516_r8 + y*128.13429152494615_r8)))) - -g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + & - y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - y*(-60.136422517125_r8 + y*10.50720794170734_r8)) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + & - y*(-433.20648175062206_r8 + 63.905091254154904_r8*y)))) - -gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 new file mode 120000 index 0000000000..e345379f5d --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_pt0_pt0.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 deleted file mode 100644 index d4b5052f99..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!========================================================================== -module gsw_mod_freezing_poly_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: c0 = 0.017947064327968736_r8 -real (r8), parameter :: c1 = -6.076099099929818_r8 -real (r8), parameter :: c2 = 4.883198653547851_r8 -real (r8), parameter :: c3 = -11.88081601230542_r8 -real (r8), parameter :: c4 = 13.34658511480257_r8 -real (r8), parameter :: c5 = -8.722761043208607_r8 -real (r8), parameter :: c6 = 2.082038908808201_r8 -real (r8), parameter :: c7 = -7.389420998107497_r8 -real (r8), parameter :: c8 = -2.110913185058476_r8 -real (r8), parameter :: c9 = 0.2295491578006229_r8 -real (r8), parameter :: c10 = -0.9891538123307282_r8 -real (r8), parameter :: c11 = -0.08987150128406496_r8 -real (r8), parameter :: c12 = 0.3831132432071728_r8 -real (r8), parameter :: c13 = 1.054318231187074_r8 -real (r8), parameter :: c14 = 1.065556599652796_r8 -real (r8), parameter :: c15 = -0.7997496801694032_r8 -real (r8), parameter :: c16 = 0.3850133554097069_r8 -real (r8), parameter :: c17 = -2.078616693017569_r8 -real (r8), parameter :: c18 = 0.8756340772729538_r8 -real (r8), parameter :: c19 = -2.079022768390933_r8 -real (r8), parameter :: c20 = 1.596435439942262_r8 -real (r8), parameter :: c21 = 0.1338002171109174_r8 -real (r8), parameter :: c22 = 1.242891021876471_r8 - -! Note that a = 0.502500117621_r8/gsw_sso -real (r8), parameter :: a = 0.014289763856964_r8 -real (r8), parameter :: b = 0.057000649899720_r8 - -real (r8), parameter :: t0 = 0.002519_r8 -real (r8), parameter :: t1 = -5.946302841607319_r8 -real (r8), parameter :: t2 = 4.136051661346983_r8 -real (r8), parameter :: t3 = -1.115150523403847e1_r8 -real (r8), parameter :: t4 = 1.476878746184548e1_r8 -real (r8), parameter :: t5 = -1.088873263630961e1_r8 -real (r8), parameter :: t6 = 2.961018839640730_r8 -real (r8), parameter :: t7 = -7.433320943962606_r8 -real (r8), parameter :: t8 = -1.561578562479883_r8 -real (r8), parameter :: t9 = 4.073774363480365e-2_r8 -real (r8), parameter :: t10 = 1.158414435887717e-2_r8 -real (r8), parameter :: t11 = -4.122639292422863e-1_r8 -real (r8), parameter :: t12 = -1.123186915628260e-1_r8 -real (r8), parameter :: t13 = 5.715012685553502e-1_r8 -real (r8), parameter :: t14 = 2.021682115652684e-1_r8 -real (r8), parameter :: t15 = 4.140574258089767e-2_r8 -real (r8), parameter :: t16 = -6.034228641903586e-1_r8 -real (r8), parameter :: t17 = -1.205825928146808e-2_r8 -real (r8), parameter :: t18 = -2.812172968619369e-1_r8 -real (r8), parameter :: t19 = 1.877244474023750e-2_r8 -real (r8), parameter :: t20 = -1.204395563789007e-1_r8 -real (r8), parameter :: t21 = 2.349147739749606e-1_r8 -real (r8), parameter :: t22 = 2.748444541144219e-3_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 new file mode 120000 index 0000000000..93ea8e1d2a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_freezing_poly_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 deleted file mode 100644 index e9da3baf48..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -module gsw_mod_gibbs_ice_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8) -complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8) - -complex(r8), parameter :: r1 =( 4.47050716285388e1_r8, 6.56876847463481e1_r8) -complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8) -complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8) -complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8) - -! 1./Pt, where Pt = 611.657; Experimental triple-point pressure in Pa. -real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8 -real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K). -real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8 ! = 1/tt - -real (r8), parameter :: g00 = -6.32020233335886e5_r8 -real (r8), parameter :: g01 = 6.55022213658955e-1_r8 -real (r8), parameter :: g02 = -1.89369929326131e-8_r8 -real (r8), parameter :: g03 = 3.3974612327105304e-15_r8 -real (r8), parameter :: g04 = -5.564648690589909e-22_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 new file mode 120000 index 0000000000..4c72d9079b --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_gibbs_ice_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 deleted file mode 100644 index 7a2a80891f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 +++ /dev/null @@ -1,16 +0,0 @@ -!========================================================================== -module gsw_mod_kinds -!========================================================================== - -implicit none - -integer, parameter :: r4 = selected_real_kind(6,30) - -integer, parameter :: r8 = selected_real_kind(14,30) - -end module - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 new file mode 120000 index 0000000000..fa0926e540 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_kinds.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 deleted file mode 100644 index 7bc89c7b5e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 +++ /dev/null @@ -1,313 +0,0 @@ -!========================================================================== -module gsw_mod_specvol_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: a000 = -1.56497346750e-5_r8 -real (r8), parameter :: a001 = 1.85057654290e-5_r8 -real (r8), parameter :: a002 = -1.17363867310e-6_r8 -real (r8), parameter :: a003 = -3.65270065530e-7_r8 -real (r8), parameter :: a004 = 3.14540999020e-7_r8 -real (r8), parameter :: a010 = 5.55242129680e-5_r8 -real (r8), parameter :: a011 = -2.34332137060e-5_r8 -real (r8), parameter :: a012 = 4.26100574800e-6_r8 -real (r8), parameter :: a013 = 5.73918103180e-7_r8 -real (r8), parameter :: a020 = -4.95634777770e-5_r8 -real (r8), parameter :: a021 = 2.37838968519e-5_r8 -real (r8), parameter :: a022 = -1.38397620111e-6_r8 -real (r8), parameter :: a030 = 2.76445290808e-5_r8 -real (r8), parameter :: a031 = -1.36408749928e-5_r8 -real (r8), parameter :: a032 = -2.53411666056e-7_r8 -real (r8), parameter :: a040 = -4.02698077700e-6_r8 -real (r8), parameter :: a041 = 2.53683834070e-6_r8 -real (r8), parameter :: a050 = 1.23258565608e-6_r8 -real (r8), parameter :: a100 = 3.50095997640e-5_r8 -real (r8), parameter :: a101 = -9.56770881560e-6_r8 -real (r8), parameter :: a102 = -5.56991545570e-6_r8 -real (r8), parameter :: a103 = -2.72956962370e-7_r8 -real (r8), parameter :: a110 = -7.48716846880e-5_r8 -real (r8), parameter :: a111 = -4.73566167220e-7_r8 -real (r8), parameter :: a112 = 7.82747741600e-7_r8 -real (r8), parameter :: a120 = 7.24244384490e-5_r8 -real (r8), parameter :: a121 = -1.03676320965e-5_r8 -real (r8), parameter :: a122 = 2.32856664276e-8_r8 -real (r8), parameter :: a130 = -3.50383492616e-5_r8 -real (r8), parameter :: a131 = 5.18268711320e-6_r8 -real (r8), parameter :: a140 = -1.65263794500e-6_r8 -real (r8), parameter :: a200 = -4.35926785610e-5_r8 -real (r8), parameter :: a201 = 1.11008347650e-5_r8 -real (r8), parameter :: a202 = 5.46207488340e-6_r8 -real (r8), parameter :: a210 = 7.18156455200e-5_r8 -real (r8), parameter :: a211 = 5.85666925900e-6_r8 -real (r8), parameter :: a212 = -1.31462208134e-6_r8 -real (r8), parameter :: a220 = -4.30608991440e-5_r8 -real (r8), parameter :: a221 = 9.49659182340e-7_r8 -real (r8), parameter :: a230 = 1.74814722392e-5_r8 -real (r8), parameter :: a300 = 3.45324618280e-5_r8 -real (r8), parameter :: a301 = -9.84471178440e-6_r8 -real (r8), parameter :: a302 = -1.35441856270e-6_r8 -real (r8), parameter :: a310 = -3.73971683740e-5_r8 -real (r8), parameter :: a311 = -9.76522784000e-7_r8 -real (r8), parameter :: a320 = 6.85899736680e-6_r8 -real (r8), parameter :: a400 = -1.19594097880e-5_r8 -real (r8), parameter :: a401 = 2.59092252600e-6_r8 -real (r8), parameter :: a410 = 7.71906784880e-6_r8 -real (r8), parameter :: a500 = 1.38645945810e-6_r8 - -real (r8), parameter :: b000 = -3.10389819760e-4_r8 -real (r8), parameter :: b003 = 3.63101885150e-7_r8 -real (r8), parameter :: b004 = -1.11471254230e-7_r8 -real (r8), parameter :: b010 = 3.50095997640e-5_r8 -real (r8), parameter :: b013 = -2.72956962370e-7_r8 -real (r8), parameter :: b020 = -3.74358423440e-5_r8 -real (r8), parameter :: b030 = 2.41414794830e-5_r8 -real (r8), parameter :: b040 = -8.75958731540e-6_r8 -real (r8), parameter :: b050 = -3.30527589000e-7_r8 -real (r8), parameter :: b100 = 1.33856134076e-3_r8 -real (r8), parameter :: b103 = 3.34926075600e-8_r8 -real (r8), parameter :: b110 = -8.71853571220e-5_r8 -real (r8), parameter :: b120 = 7.18156455200e-5_r8 -real (r8), parameter :: b130 = -2.87072660960e-5_r8 -real (r8), parameter :: b140 = 8.74073611960e-6_r8 -real (r8), parameter :: b200 = -2.55143801811e-3_r8 -real (r8), parameter :: b210 = 1.03597385484e-4_r8 -real (r8), parameter :: b220 = -5.60957525610e-5_r8 -real (r8), parameter :: b230 = 6.85899736680e-6_r8 -real (r8), parameter :: b300 = 2.32344279772e-3_r8 -real (r8), parameter :: b310 = -4.78376391520e-5_r8 -real (r8), parameter :: b320 = 1.54381356976e-5_r8 -real (r8), parameter :: b400 = -1.05461852535e-3_r8 -real (r8), parameter :: b410 = 6.93229729050e-6_r8 -real (r8), parameter :: b500 = 1.91594743830e-4_r8 -real (r8), parameter :: b001 = 2.42624687470e-5_r8 -real (r8), parameter :: b011 = -9.56770881560e-6_r8 -real (r8), parameter :: b021 = -2.36783083610e-7_r8 -real (r8), parameter :: b031 = -3.45587736550e-6_r8 -real (r8), parameter :: b041 = 1.29567177830e-6_r8 -real (r8), parameter :: b101 = -6.95849219480e-5_r8 -real (r8), parameter :: b111 = 2.22016695300e-5_r8 -real (r8), parameter :: b121 = 5.85666925900e-6_r8 -real (r8), parameter :: b131 = 6.33106121560e-7_r8 -real (r8), parameter :: b201 = 1.12412331915e-4_r8 -real (r8), parameter :: b211 = -2.95341353532e-5_r8 -real (r8), parameter :: b221 = -1.46478417600e-6_r8 -real (r8), parameter :: b301 = -6.92888744480e-5_r8 -real (r8), parameter :: b311 = 1.03636901040e-5_r8 -real (r8), parameter :: b401 = 1.54637136265e-5_r8 -real (r8), parameter :: b002 = -5.84844329840e-7_r8 -real (r8), parameter :: b012 = -5.56991545570e-6_r8 -real (r8), parameter :: b022 = 3.91373870800e-7_r8 -real (r8), parameter :: b032 = 7.76188880920e-9_r8 -real (r8), parameter :: b102 = -9.62445031940e-6_r8 -real (r8), parameter :: b112 = 1.09241497668e-5_r8 -real (r8), parameter :: b122 = -1.31462208134e-6_r8 -real (r8), parameter :: b202 = 1.47789320994e-5_r8 -real (r8), parameter :: b212 = -4.06325568810e-6_r8 -real (r8), parameter :: b302 = -7.12478989080e-6_r8 - -real (r8), parameter :: c000 = -6.07991438090e-5_r8 -real (r8), parameter :: c001 = 1.99712338438e-5_r8 -real (r8), parameter :: c002 = -3.39280843110e-6_r8 -real (r8), parameter :: c003 = 4.21246123200e-7_r8 -real (r8), parameter :: c004 = -6.32363064300e-8_r8 -real (r8), parameter :: c005 = 1.17681023580e-8_r8 -real (r8), parameter :: c010 = 1.85057654290e-5_r8 -real (r8), parameter :: c011 = -2.34727734620e-6_r8 -real (r8), parameter :: c012 = -1.09581019659e-6_r8 -real (r8), parameter :: c013 = 1.25816399608e-6_r8 -real (r8), parameter :: c020 = -1.17166068530e-5_r8 -real (r8), parameter :: c021 = 4.26100574800e-6_r8 -real (r8), parameter :: c022 = 8.60877154770e-7_r8 -real (r8), parameter :: c030 = 7.92796561730e-6_r8 -real (r8), parameter :: c031 = -9.22650800740e-7_r8 -real (r8), parameter :: c040 = -3.41021874820e-6_r8 -real (r8), parameter :: c041 = -1.26705833028e-7_r8 -real (r8), parameter :: c050 = 5.07367668140e-7_r8 -real (r8), parameter :: c100 = 2.42624687470e-5_r8 -real (r8), parameter :: c101 = -1.16968865968e-6_r8 -real (r8), parameter :: c102 = 1.08930565545e-6_r8 -real (r8), parameter :: c103 = -4.45885016920e-7_r8 -real (r8), parameter :: c110 = -9.56770881560e-6_r8 -real (r8), parameter :: c111 = -1.11398309114e-5_r8 -real (r8), parameter :: c112 = -8.18870887110e-7_r8 -real (r8), parameter :: c120 = -2.36783083610e-7_r8 -real (r8), parameter :: c121 = 7.82747741600e-7_r8 -real (r8), parameter :: c130 = -3.45587736550e-6_r8 -real (r8), parameter :: c131 = 1.55237776184e-8_r8 -real (r8), parameter :: c140 = 1.29567177830e-6_r8 -real (r8), parameter :: c200 = -3.47924609740e-5_r8 -real (r8), parameter :: c201 = -9.62445031940e-6_r8 -real (r8), parameter :: c202 = 5.02389113400e-8_r8 -real (r8), parameter :: c210 = 1.11008347650e-5_r8 -real (r8), parameter :: c211 = 1.09241497668e-5_r8 -real (r8), parameter :: c220 = 2.92833462950e-6_r8 -real (r8), parameter :: c221 = -1.31462208134e-6_r8 -real (r8), parameter :: c230 = 3.16553060780e-7_r8 -real (r8), parameter :: c300 = 3.74707773050e-5_r8 -real (r8), parameter :: c301 = 9.85262139960e-6_r8 -real (r8), parameter :: c310 = -9.84471178440e-6_r8 -real (r8), parameter :: c311 = -2.70883712540e-6_r8 -real (r8), parameter :: c320 = -4.88261392000e-7_r8 -real (r8), parameter :: c400 = -1.73222186120e-5_r8 -real (r8), parameter :: c401 = -3.56239494540e-6_r8 -real (r8), parameter :: c410 = 2.59092252600e-6_r8 -real (r8), parameter :: c500 = 3.09274272530e-6_r8 - -real (r8), parameter :: h001 = 1.07699958620e-3_r8 -real (r8), parameter :: h002 = -3.03995719050e-5_r8 -real (r8), parameter :: h003 = 3.32853897400e-6_r8 -real (r8), parameter :: h004 = -2.82734035930e-7_r8 -real (r8), parameter :: h005 = 2.10623061600e-8_r8 -real (r8), parameter :: h006 = -2.10787688100e-9_r8 -real (r8), parameter :: h007 = 2.80192913290e-10_r8 -real (r8), parameter :: h011 = -1.56497346750e-5_r8 -real (r8), parameter :: h012 = 9.25288271450e-6_r8 -real (r8), parameter :: h013 = -3.91212891030e-7_r8 -real (r8), parameter :: h014 = -9.13175163830e-8_r8 -real (r8), parameter :: h015 = 6.29081998040e-8_r8 -real (r8), parameter :: h021 = 2.77621064840e-5_r8 -real (r8), parameter :: h022 = -5.85830342650e-6_r8 -real (r8), parameter :: h023 = 7.10167624670e-7_r8 -real (r8), parameter :: h024 = 7.17397628980e-8_r8 -real (r8), parameter :: h031 = -1.65211592590e-5_r8 -real (r8), parameter :: h032 = 3.96398280870e-6_r8 -real (r8), parameter :: h033 = -1.53775133460e-7_r8 -real (r8), parameter :: h042 = -1.70510937410e-6_r8 -real (r8), parameter :: h043 = -2.11176388380e-8_r8 -real (r8), parameter :: h041 = 6.91113227020e-6_r8 -real (r8), parameter :: h051 = -8.05396155400e-7_r8 -real (r8), parameter :: h052 = 2.53683834070e-7_r8 -real (r8), parameter :: h061 = 2.05430942680e-7_r8 -real (r8), parameter :: h101 = -3.10389819760e-4_r8 -real (r8), parameter :: h102 = 1.21312343735e-5_r8 -real (r8), parameter :: h103 = -1.94948109950e-7_r8 -real (r8), parameter :: h104 = 9.07754712880e-8_r8 -real (r8), parameter :: h105 = -2.22942508460e-8_r8 -real (r8), parameter :: h111 = 3.50095997640e-5_r8 -real (r8), parameter :: h112 = -4.78385440780e-6_r8 -real (r8), parameter :: h113 = -1.85663848520e-6_r8 -real (r8), parameter :: h114 = -6.82392405930e-8_r8 -real (r8), parameter :: h121 = -3.74358423440e-5_r8 -real (r8), parameter :: h122 = -1.18391541805e-7_r8 -real (r8), parameter :: h123 = 1.30457956930e-7_r8 -real (r8), parameter :: h131 = 2.41414794830e-5_r8 -real (r8), parameter :: h132 = -1.72793868275e-6_r8 -real (r8), parameter :: h133 = 2.58729626970e-9_r8 -real (r8), parameter :: h141 = -8.75958731540e-6_r8 -real (r8), parameter :: h142 = 6.47835889150e-7_r8 -real (r8), parameter :: h151 = -3.30527589000e-7_r8 -real (r8), parameter :: h201 = 6.69280670380e-4_r8 -real (r8), parameter :: h202 = -1.73962304870e-5_r8 -real (r8), parameter :: h203 = -1.60407505320e-6_r8 -real (r8), parameter :: h204 = 4.18657594500e-9_r8 -real (r8), parameter :: h211 = -4.35926785610e-5_r8 -real (r8), parameter :: h212 = 5.55041738250e-6_r8 -real (r8), parameter :: h213 = 1.82069162780e-6_r8 -real (r8), parameter :: h221 = 3.59078227600e-5_r8 -real (r8), parameter :: h222 = 1.46416731475e-6_r8 -real (r8), parameter :: h223 = -2.19103680220e-7_r8 -real (r8), parameter :: h231 = -1.43536330480e-5_r8 -real (r8), parameter :: h232 = 1.58276530390e-7_r8 -real (r8), parameter :: h241 = 4.37036805980e-6_r8 -real (r8), parameter :: h301 = -8.50479339370e-4_r8 -real (r8), parameter :: h302 = 1.87353886525e-5_r8 -real (r8), parameter :: h303 = 1.64210356660e-6_r8 -real (r8), parameter :: h311 = 3.45324618280e-5_r8 -real (r8), parameter :: h312 = -4.92235589220e-6_r8 -real (r8), parameter :: h313 = -4.51472854230e-7_r8 -real (r8), parameter :: h321 = -1.86985841870e-5_r8 -real (r8), parameter :: h322 = -2.44130696000e-7_r8 -real (r8), parameter :: h331 = 2.28633245560e-6_r8 -real (r8), parameter :: h401 = 5.80860699430e-4_r8 -real (r8), parameter :: h402 = -8.66110930600e-6_r8 -real (r8), parameter :: h403 = -5.93732490900e-7_r8 -real (r8), parameter :: h411 = -1.19594097880e-5_r8 -real (r8), parameter :: h421 = 3.85953392440e-6_r8 -real (r8), parameter :: h412 = 1.29546126300e-6_r8 -real (r8), parameter :: h501 = -2.10923705070e-4_r8 -real (r8), parameter :: h502 = 1.54637136265e-6_r8 -real (r8), parameter :: h511 = 1.38645945810e-6_r8 -real (r8), parameter :: h601 = 3.19324573050e-5_r8 - -real (r8), parameter :: v000 = 1.0769995862e-3_r8 -real (r8), parameter :: v001 = -6.0799143809e-5_r8 -real (r8), parameter :: v002 = 9.9856169219e-6_r8 -real (r8), parameter :: v003 = -1.1309361437e-6_r8 -real (r8), parameter :: v004 = 1.0531153080e-7_r8 -real (r8), parameter :: v005 = -1.2647261286e-8_r8 -real (r8), parameter :: v006 = 1.9613503930e-9_r8 -real (r8), parameter :: v010 = -3.1038981976e-4_r8 -real (r8), parameter :: v011 = 2.4262468747e-5_r8 -real (r8), parameter :: v012 = -5.8484432984e-7_r8 -real (r8), parameter :: v013 = 3.6310188515e-7_r8 -real (r8), parameter :: v014 = -1.1147125423e-7_r8 -real (r8), parameter :: v020 = 6.6928067038e-4_r8 -real (r8), parameter :: v021 = -3.4792460974e-5_r8 -real (r8), parameter :: v022 = -4.8122251597e-6_r8 -real (r8), parameter :: v023 = 1.6746303780e-8_r8 -real (r8), parameter :: v030 = -8.5047933937e-4_r8 -real (r8), parameter :: v031 = 3.7470777305e-5_r8 -real (r8), parameter :: v032 = 4.9263106998e-6_r8 -real (r8), parameter :: v040 = 5.8086069943e-4_r8 -real (r8), parameter :: v041 = -1.7322218612e-5_r8 -real (r8), parameter :: v042 = -1.7811974727e-6_r8 -real (r8), parameter :: v050 = -2.1092370507e-4_r8 -real (r8), parameter :: v051 = 3.0927427253e-6_r8 -real (r8), parameter :: v060 = 3.1932457305e-5_r8 -real (r8), parameter :: v100 = -1.5649734675e-5_r8 -real (r8), parameter :: v101 = 1.8505765429e-5_r8 -real (r8), parameter :: v102 = -1.1736386731e-6_r8 -real (r8), parameter :: v103 = -3.6527006553e-7_r8 -real (r8), parameter :: v104 = 3.1454099902e-7_r8 -real (r8), parameter :: v110 = 3.5009599764e-5_r8 -real (r8), parameter :: v111 = -9.5677088156e-6_r8 -real (r8), parameter :: v112 = -5.5699154557e-6_r8 -real (r8), parameter :: v113 = -2.7295696237e-7_r8 -real (r8), parameter :: v120 = -4.3592678561e-5_r8 -real (r8), parameter :: v121 = 1.1100834765e-5_r8 -real (r8), parameter :: v122 = 5.4620748834e-6_r8 -real (r8), parameter :: v130 = 3.4532461828e-5_r8 -real (r8), parameter :: v131 = -9.8447117844e-6_r8 -real (r8), parameter :: v132 = -1.3544185627e-6_r8 -real (r8), parameter :: v140 = -1.1959409788e-5_r8 -real (r8), parameter :: v141 = 2.5909225260e-6_r8 -real (r8), parameter :: v150 = 1.3864594581e-6_r8 -real (r8), parameter :: v200 = 2.7762106484e-5_r8 -real (r8), parameter :: v201 = -1.1716606853e-5_r8 -real (r8), parameter :: v202 = 2.1305028740e-6_r8 -real (r8), parameter :: v203 = 2.8695905159e-7_r8 -real (r8), parameter :: v210 = -3.7435842344e-5_r8 -real (r8), parameter :: v211 = -2.3678308361e-7_r8 -real (r8), parameter :: v212 = 3.9137387080e-7_r8 -real (r8), parameter :: v220 = 3.5907822760e-5_r8 -real (r8), parameter :: v221 = 2.9283346295e-6_r8 -real (r8), parameter :: v222 = -6.5731104067e-7_r8 -real (r8), parameter :: v230 = -1.8698584187e-5_r8 -real (r8), parameter :: v231 = -4.8826139200e-7_r8 -real (r8), parameter :: v240 = 3.8595339244e-6_r8 -real (r8), parameter :: v300 = -1.6521159259e-5_r8 -real (r8), parameter :: v301 = 7.9279656173e-6_r8 -real (r8), parameter :: v302 = -4.6132540037e-7_r8 -real (r8), parameter :: v310 = 2.4141479483e-5_r8 -real (r8), parameter :: v311 = -3.4558773655e-6_r8 -real (r8), parameter :: v312 = 7.7618888092e-9_r8 -real (r8), parameter :: v320 = -1.4353633048e-5_r8 -real (r8), parameter :: v321 = 3.1655306078e-7_r8 -real (r8), parameter :: v330 = 2.2863324556e-6_r8 -real (r8), parameter :: v400 = 6.9111322702e-6_r8 -real (r8), parameter :: v401 = -3.4102187482e-6_r8 -real (r8), parameter :: v402 = -6.3352916514e-8_r8 -real (r8), parameter :: v410 = -8.7595873154e-6_r8 -real (r8), parameter :: v411 = 1.2956717783e-6_r8 -real (r8), parameter :: v420 = 4.3703680598e-6_r8 -real (r8), parameter :: v500 = -8.0539615540e-7_r8 -real (r8), parameter :: v501 = 5.0736766814e-7_r8 -real (r8), parameter :: v510 = -3.3052758900e-7_r8 -real (r8), parameter :: v600 = 2.0543094268e-7_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 new file mode 120000 index 0000000000..934f689c20 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_specvol_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 deleted file mode 100644 index e3c6afbce0..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -module gsw_mod_teos10_constants -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: db2pa = 1.0e4_r8 -real (r8), parameter :: rec_db2pa = 1.0e-4_r8 - -real (r8), parameter :: pa2db = 1.0e-4_r8 -real (r8), parameter :: rec_pa2db = 1.0e4_r8 - -real (r8), parameter :: pi = 3.141592653589793_r8 -real (r8), parameter :: deg2rad = pi/180.0_r8 -real (r8), parameter :: rad2deg = 180.0_r8/pi - -real (r8), parameter :: gamma = 2.26e-7_r8 - -! cp0 = The "specific heat" for use [ J/(kg K) ] -! with Conservative Temperature - -real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8 - -! T0 = the Celcius zero point. [ K ] - -real (r8), parameter :: gsw_t0 = 273.15_r8 - -! P0 = Absolute Pressure of one standard atmosphere. [ Pa ] - -real (r8), parameter :: gsw_p0 = 101325.0_r8 - -! SSO = Standard Ocean Reference Salinity. [ g/kg ] - -real (r8), parameter :: gsw_sso = 35.16504_r8 -real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8 - -! uPS = unit conversion factor for salinities [ g/kg ] - -real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8 - -! sfac = 1/(40*gsw_ups) - -real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8 - -! deltaS = 24, offset = deltaS*gsw_sfac - -real (r8), parameter :: offset = 5.971840214030754e-1_r8 - -! C3515 = Conductivity at (SP=35, t_68=15, p=0) [ mS/cm ] - -real (r8), parameter :: gsw_c3515 = 42.9140_r8 - -! SonCl = SP to Chlorinity ratio [ (g/kg)^-1 ] - -real (r8), parameter :: gsw_soncl = 1.80655_r8 - -! valence_factor = valence factor of sea salt of Reference Composition -! [ unitless ] - -real (r8), parameter :: gsw_valence_factor = 1.2452898_r8 - -! atomic_weight = mole-weighted atomic weight of sea salt of Reference -! Composition [ g/mol ] - -real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 new file mode 120000 index 0000000000..17dec5add5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_teos10_constants.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 deleted file mode 100644 index a8012e1274..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 +++ /dev/null @@ -1,1493 +0,0 @@ -module gsw_mod_toolbox - -use gsw_mod_kinds - -implicit none - -public :: gsw_add_barrier -public :: gsw_add_mean -public :: gsw_adiabatic_lapse_rate_from_ct -public :: gsw_adiabatic_lapse_rate_ice -public :: gsw_alpha -public :: gsw_alpha_on_beta -public :: gsw_alpha_wrt_t_exact -public :: gsw_alpha_wrt_t_ice -public :: gsw_beta_const_t_exact -public :: gsw_beta -public :: gsw_cabbeling -public :: gsw_c_from_sp -public :: gsw_chem_potential_water_ice -public :: gsw_chem_potential_water_t_exact -public :: gsw_cp_ice -public :: gsw_ct_first_derivatives -public :: gsw_ct_first_derivatives_wrt_t_exact -public :: gsw_ct_freezing_exact -public :: gsw_ct_freezing -public :: gsw_ct_freezing_first_derivatives -public :: gsw_ct_freezing_first_derivatives_poly -public :: gsw_ct_freezing_poly -public :: gsw_ct_from_enthalpy_exact -public :: gsw_ct_from_enthalpy -public :: gsw_ct_from_entropy -public :: gsw_ct_from_pt -public :: gsw_ct_from_rho -public :: gsw_ct_from_t -public :: gsw_ct_maxdensity -public :: gsw_ct_second_derivatives -public :: gsw_deltasa_atlas -public :: gsw_deltasa_from_sp -public :: gsw_dilution_coefficient_t_exact -public :: gsw_dynamic_enthalpy -public :: gsw_enthalpy_ct_exact -public :: gsw_enthalpy_diff -public :: gsw_enthalpy -public :: gsw_enthalpy_first_derivatives_ct_exact -public :: gsw_enthalpy_first_derivatives -public :: gsw_enthalpy_ice -public :: gsw_enthalpy_second_derivatives_ct_exact -public :: gsw_enthalpy_second_derivatives -public :: gsw_enthalpy_sso_0 -public :: gsw_enthalpy_t_exact -public :: gsw_entropy_first_derivatives -public :: gsw_entropy_from_pt -public :: gsw_entropy_from_t -public :: gsw_entropy_ice -public :: gsw_entropy_part -public :: gsw_entropy_part_zerop -public :: gsw_entropy_second_derivatives -public :: gsw_fdelta -public :: gsw_frazil_properties -public :: gsw_frazil_properties_potential -public :: gsw_frazil_properties_potential_poly -public :: gsw_frazil_ratios_adiabatic -public :: gsw_frazil_ratios_adiabatic_poly -public :: gsw_geo_strf_dyn_height -public :: gsw_geo_strf_dyn_height_pc -public :: gsw_gibbs -public :: gsw_gibbs_ice -public :: gsw_gibbs_ice_part_t -public :: gsw_gibbs_ice_pt0 -public :: gsw_gibbs_ice_pt0_pt0 -public :: gsw_gibbs_pt0_pt0 -public :: gsw_grav -public :: gsw_helmholtz_energy_ice -public :: gsw_hill_ratio_at_sp2 -public :: gsw_ice_fraction_to_freeze_seawater -public :: gsw_internal_energy -public :: gsw_internal_energy_ice -public :: gsw_ipv_vs_fnsquared_ratio -public :: gsw_kappa_const_t_ice -public :: gsw_kappa -public :: gsw_kappa_ice -public :: gsw_kappa_t_exact -public :: gsw_latentheat_evap_ct -public :: gsw_latentheat_evap_t -public :: gsw_latentheat_melting -public :: gsw_linear_interp_sa_ct -public :: gsw_melting_ice_equilibrium_sa_ct_ratio -public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_ice_into_seawater -public :: gsw_melting_ice_sa_ct_ratio -public :: gsw_melting_ice_sa_ct_ratio_poly -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_seaice_into_seawater -public :: gsw_melting_seaice_sa_ct_ratio -public :: gsw_melting_seaice_sa_ct_ratio_poly -public :: gsw_nsquared -public :: gsw_pot_enthalpy_from_pt_ice -public :: gsw_pot_enthalpy_from_pt_ice_poly -public :: gsw_pot_enthalpy_ice_freezing -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly -public :: gsw_pot_enthalpy_ice_freezing_poly -public :: gsw_pot_rho_t_exact -public :: gsw_pressure_coefficient_ice -public :: gsw_pressure_freezing_ct -public :: gsw_pt0_cold_ice_poly -public :: gsw_pt0_from_t -public :: gsw_pt0_from_t_ice -public :: gsw_pt_first_derivatives -public :: gsw_pt_from_ct -public :: gsw_pt_from_entropy -public :: gsw_pt_from_pot_enthalpy_ice -public :: gsw_pt_from_pot_enthalpy_ice_poly_dh -public :: gsw_pt_from_pot_enthalpy_ice_poly -public :: gsw_pt_from_t -public :: gsw_pt_from_t_ice -public :: gsw_pt_second_derivatives -public :: gsw_rho_alpha_beta -public :: gsw_rho -public :: gsw_rho_first_derivatives -public :: gsw_rho_first_derivatives_wrt_enthalpy -public :: gsw_rho_ice -public :: gsw_rho_second_derivatives -public :: gsw_rho_second_derivatives_wrt_enthalpy -public :: gsw_rho_t_exact -public :: gsw_rr68_interp_sa_ct -public :: gsw_saar -public :: gsw_sa_freezing_estimate -public :: gsw_sa_freezing_from_ct -public :: gsw_sa_freezing_from_ct_poly -public :: gsw_sa_freezing_from_t -public :: gsw_sa_freezing_from_t_poly -public :: gsw_sa_from_rho -public :: gsw_sa_from_sp_baltic -public :: gsw_sa_from_sp -public :: gsw_sa_from_sstar -public :: gsw_sa_p_inrange -public :: gsw_seaice_fraction_to_freeze_seawater -public :: gsw_sigma0 -public :: gsw_sigma1 -public :: gsw_sigma2 -public :: gsw_sigma3 -public :: gsw_sigma4 -public :: gsw_sound_speed -public :: gsw_sound_speed_ice -public :: gsw_sound_speed_t_exact -public :: gsw_specvol_alpha_beta -public :: gsw_specvol_anom_standard -public :: gsw_specvol -public :: gsw_specvol_first_derivatives -public :: gsw_specvol_first_derivatives_wrt_enthalpy -public :: gsw_specvol_ice -public :: gsw_specvol_second_derivatives -public :: gsw_specvol_second_derivatives_wrt_enthalpy -public :: gsw_specvol_sso_0 -public :: gsw_specvol_t_exact -public :: gsw_sp_from_c -public :: gsw_sp_from_sa_baltic -public :: gsw_sp_from_sa -public :: gsw_sp_from_sk -public :: gsw_sp_from_sr -public :: gsw_sp_from_sstar -public :: gsw_spiciness0 -public :: gsw_spiciness1 -public :: gsw_spiciness2 -public :: gsw_sr_from_sp -public :: gsw_sstar_from_sa -public :: gsw_sstar_from_sp -public :: gsw_t_deriv_chem_potential_water_t_exact -public :: gsw_t_freezing_exact -public :: gsw_t_freezing -public :: gsw_t_freezing_first_derivatives -public :: gsw_t_freezing_first_derivatives_poly -public :: gsw_t_freezing_poly -public :: gsw_t_from_ct -public :: gsw_t_from_pt0_ice -public :: gsw_thermobaric -public :: gsw_turner_rsubrho -public :: gsw_util_indx -public :: gsw_util_interp1q_int -public :: gsw_util_sort_real -public :: gsw_util_xinterp1 -public :: gsw_z_from_p - -interface - - pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, & - lat_grid, dlong_grid, dlat_grid, output_data) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid - real (r8), intent(in) :: dlat_grid - real (r8), intent(in), dimension(4) :: input_data - real (r8), intent(out), dimension(4) :: output_data - end subroutine gsw_add_barrier - - pure subroutine gsw_add_mean (data_in, data_out) - use gsw_mod_kinds - implicit none - real (r8), intent(in), dimension(4) :: data_in - real (r8), intent(out), dimension(4) :: data_out - end subroutine gsw_add_mean - - elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_adiabatic_lapse_rate_from_ct - end function gsw_adiabatic_lapse_rate_from_ct - - elemental function gsw_adiabatic_lapse_rate_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_adiabatic_lapse_rate_ice - end function gsw_adiabatic_lapse_rate_ice - - elemental function gsw_alpha (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha - end function gsw_alpha - - elemental function gsw_alpha_on_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha_on_beta - end function gsw_alpha_on_beta - - elemental function gsw_alpha_wrt_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_alpha_wrt_t_exact - end function gsw_alpha_wrt_t_exact - - elemental function gsw_alpha_wrt_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_alpha_wrt_t_ice - end function gsw_alpha_wrt_t_ice - - elemental function gsw_beta_const_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_beta_const_t_exact - end function gsw_beta_const_t_exact - - elemental function gsw_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_beta - end function gsw_beta - - elemental function gsw_cabbeling (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_cabbeling - end function gsw_cabbeling - - elemental function gsw_c_from_sp (sp, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, t, p - real (r8) :: gsw_c_from_sp - end function gsw_c_from_sp - - elemental function gsw_chem_potential_water_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_chem_potential_water_ice - end function gsw_chem_potential_water_ice - - elemental function gsw_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_chem_potential_water_t_exact - end function gsw_chem_potential_water_t_exact - - elemental function gsw_cp_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_cp_ice - end function gsw_cp_ice - - elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa, ct_pt - end subroutine gsw_ct_first_derivatives - - elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, & - ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t - end subroutine gsw_ct_first_derivatives_wrt_t_exact - - elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_exact - end function gsw_ct_freezing_exact - - elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_ct_freezing - end function gsw_ct_freezing - - elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives - - elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives_poly - - elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_poly - end function gsw_ct_freezing_poly - - elemental function gsw_ct_from_enthalpy_exact (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy_exact - end function gsw_ct_from_enthalpy_exact - - elemental function gsw_ct_from_enthalpy (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy - end function gsw_ct_from_enthalpy - - elemental function gsw_ct_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_ct_from_entropy - end function gsw_ct_from_entropy - - elemental function gsw_ct_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_ct_from_pt - end function gsw_ct_from_pt - - elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, sa, p - real (r8), intent(out) :: ct - real (r8), intent(out), optional :: ct_multiple - end subroutine gsw_ct_from_rho - - elemental function gsw_ct_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_ct_from_t - end function gsw_ct_from_t - - elemental function gsw_ct_maxdensity (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_ct_maxdensity - end function gsw_ct_maxdensity - - elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, & - ct_pt_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt - end subroutine gsw_ct_second_derivatives - - elemental function gsw_deltasa_atlas (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_deltasa_atlas - end function gsw_deltasa_atlas - - elemental function gsw_deltasa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_deltasa_from_sp - end function gsw_deltasa_from_sp - - elemental function gsw_dilution_coefficient_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_dilution_coefficient_t_exact - end function gsw_dilution_coefficient_t_exact - - elemental function gsw_dynamic_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_dynamic_enthalpy - end function gsw_dynamic_enthalpy - - elemental function gsw_enthalpy_ct_exact (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy_ct_exact - end function gsw_enthalpy_ct_exact - - elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p_shallow, p_deep - real (r8) :: gsw_enthalpy_diff - end function gsw_enthalpy_diff - - elemental function gsw_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy - end function gsw_enthalpy - - elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, & - h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives - - elemental function gsw_enthalpy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_enthalpy_ice - end function gsw_enthalpy_ice - - elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, & - h_sa_sa, h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, & - h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives - - elemental function gsw_enthalpy_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_enthalpy_sso_0 - end function gsw_enthalpy_sso_0 - - elemental function gsw_enthalpy_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_enthalpy_t_exact - end function gsw_enthalpy_t_exact - - elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa, eta_ct - end subroutine gsw_entropy_first_derivatives - - elemental function gsw_entropy_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_entropy_from_pt - end function gsw_entropy_from_pt - - elemental function gsw_entropy_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_from_t - end function gsw_entropy_from_t - - elemental function gsw_entropy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_entropy_ice - end function gsw_entropy_ice - - elemental function gsw_entropy_part (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_part - end function gsw_entropy_part - - elemental function gsw_entropy_part_zerop (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_entropy_part_zerop - end function gsw_entropy_part_zerop - - elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, & - eta_sa_ct, eta_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct - end subroutine gsw_entropy_second_derivatives - - elemental function gsw_fdelta (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_fdelta - end function gsw_fdelta - - elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, & - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties - - elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,& - p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential - - elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, & - h_pot_bulk, p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential_poly - - elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic - - elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic_poly - - pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8) :: gsw_geo_strf_dyn_height(size(sa)) - end function gsw_geo_strf_dyn_height - - pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, & - geo_strf_dyn_height_pc, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), delta_p(:) - real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:) - end subroutine gsw_geo_strf_dyn_height_pc - - elemental function gsw_gibbs (ns, nt, np, sa, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: ns, nt, np - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_gibbs - end function gsw_gibbs - - elemental function gsw_gibbs_ice (nt, np, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: nt, np - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice - end function gsw_gibbs_ice - - elemental function gsw_gibbs_ice_part_t (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice_part_t - end function gsw_gibbs_ice_part_t - - elemental function gsw_gibbs_ice_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0 - end function gsw_gibbs_ice_pt0 - - elemental function gsw_gibbs_ice_pt0_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0_pt0 - end function gsw_gibbs_ice_pt0_pt0 - - elemental function gsw_gibbs_pt0_pt0 (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_gibbs_pt0_pt0 - end function gsw_gibbs_pt0_pt0 - - elemental function gsw_grav (lat, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: lat, p - real (r8) :: gsw_grav - end function gsw_grav - - elemental function gsw_helmholtz_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_helmholtz_energy_ice - end function gsw_helmholtz_energy_ice - - elemental function gsw_hill_ratio_at_sp2 (t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t - real (r8) :: gsw_hill_ratio_at_sp2 - end function gsw_hill_ratio_at_sp2 - - elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, & - t_ih, sa_freeze, ct_freeze, w_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih - end subroutine gsw_ice_fraction_to_freeze_seawater - - elemental function gsw_internal_energy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_internal_energy - end function gsw_internal_energy - - elemental function gsw_internal_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_internal_energy_ice - end function gsw_internal_energy_ice - - pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, & - ipv_vs_fnsquared_ratio, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:) - end subroutine gsw_ipv_vs_fnsquared_ratio - - elemental function gsw_kappa_const_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_const_t_ice - end function gsw_kappa_const_t_ice - - elemental function gsw_kappa (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_kappa - end function gsw_kappa - - elemental function gsw_kappa_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_ice - end function gsw_kappa_ice - - elemental function gsw_kappa_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_kappa_t_exact - end function gsw_kappa_t_exact - - elemental function gsw_latentheat_evap_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_latentheat_evap_ct - end function gsw_latentheat_evap_ct - - elemental function gsw_latentheat_evap_t (sa, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t - real (r8) :: gsw_latentheat_evap_t - end function gsw_latentheat_evap_t - - elemental function gsw_latentheat_melting (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_latentheat_melting - end function gsw_latentheat_melting - - pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_linear_interp_sa_ct - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio - end function gsw_melting_ice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,& - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_ih, t_ih - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_melting_ice_into_seawater - - elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio - end function gsw_melting_ice_sa_ct_ratio - - elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio_poly - end function gsw_melting_ice_sa_ct_ratio_poly - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio - end function gsw_melting_seaice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, & - w_seaice, sa_seaice, t_seaice, sa_final, ct_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice - real (r8), intent(out) :: sa_final, ct_final - end subroutine gsw_melting_seaice_into_seawater - - elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, & - t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio - end function gsw_melting_seaice_sa_ct_ratio - - elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, & - sa_seaice, t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly - end function gsw_melting_seaice_sa_ct_ratio_poly - - pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:) - real (r8), intent(out) :: n2(:), p_mid(:) - end subroutine gsw_nsquared - - elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice - end function gsw_pot_enthalpy_from_pt_ice - - elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly - end function gsw_pot_enthalpy_from_pt_ice_poly - - elemental function gsw_pot_enthalpy_ice_freezing (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing - end function gsw_pot_enthalpy_ice_freezing - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, & - p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(& - sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly - - elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing_poly - end function gsw_pot_enthalpy_ice_freezing_poly - - elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pot_rho_t_exact - end function gsw_pot_rho_t_exact - - elemental function gsw_pressure_coefficient_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pressure_coefficient_ice - end function gsw_pressure_coefficient_ice - - elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, saturation_fraction - real (r8) :: gsw_pressure_freezing_ct - end function gsw_pressure_freezing_ct - - elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt0_cold_ice_poly - end function gsw_pt0_cold_ice_poly - - elemental function gsw_pt0_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_pt0_from_t - end function gsw_pt0_from_t - - elemental function gsw_pt0_from_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pt0_from_t_ice - end function gsw_pt0_from_t_ice - - elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa, pt_ct - end subroutine gsw_pt_first_derivatives - - elemental function gsw_pt_from_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_pt_from_ct - end function gsw_pt_from_ct - - elemental function gsw_pt_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_pt_from_entropy - end function gsw_pt_from_entropy - - elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice - end function gsw_pt_from_pot_enthalpy_ice - - elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh - end function gsw_pt_from_pot_enthalpy_ice_poly_dh - - elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly - end function gsw_pt_from_pot_enthalpy_ice_poly - - elemental function gsw_pt_from_t (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pt_from_t - end function gsw_pt_from_t - - elemental function gsw_pt_from_t_ice (t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, p_ref - real (r8) :: gsw_pt_from_t_ice - end function gsw_pt_from_t_ice - - elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, & - pt_sa_ct, pt_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct - end subroutine gsw_pt_second_derivatives - - elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho, alpha, beta - end subroutine gsw_rho_alpha_beta - - elemental function gsw_rho (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_rho - end function gsw_rho - - elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - end subroutine gsw_rho_first_derivatives - - elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa, rho_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa, rho_h - end subroutine gsw_rho_first_derivatives_wrt_enthalpy - - elemental function gsw_rho_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_rho_ice - end function gsw_rho_ice - - elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct - real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - end subroutine gsw_rho_second_derivatives - - elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa_sa, rho_sa_h, rho_h_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h - end subroutine gsw_rho_second_derivatives_wrt_enthalpy - - elemental function gsw_rho_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_rho_t_exact - end function gsw_rho_t_exact - - pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_rr68_interp_sa_ct - - elemental function gsw_saar (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_saar - end function gsw_saar - - elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, saturation_fraction - real (r8), intent(in), optional :: ct, t - real (r8) :: gsw_sa_freezing_estimate - end function gsw_sa_freezing_estimate - - elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct - end function gsw_sa_freezing_from_ct - - elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct_poly - end function gsw_sa_freezing_from_ct_poly - - elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t - end function gsw_sa_freezing_from_t - - elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t_poly - end function gsw_sa_freezing_from_t_poly - - elemental function gsw_sa_from_rho (rho, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, ct, p - real (r8) :: gsw_sa_from_rho - end function gsw_sa_from_rho - - elemental function gsw_sa_from_sp_baltic (sp, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, long, lat - real (r8) :: gsw_sa_from_sp_baltic - end function gsw_sa_from_sp_baltic - - elemental function gsw_sa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sa_from_sp - end function gsw_sa_from_sp - - elemental function gsw_sa_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sa_from_sstar - end function gsw_sa_from_sstar - - elemental function gsw_sa_p_inrange (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - logical :: gsw_sa_p_inrange - end function gsw_sa_p_inrange - - elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, & - sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice - end subroutine gsw_seaice_fraction_to_freeze_seawater - - elemental function gsw_sigma0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma0 - end function gsw_sigma0 - - elemental function gsw_sigma1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma1 - end function gsw_sigma1 - - elemental function gsw_sigma2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma2 - end function gsw_sigma2 - - elemental function gsw_sigma3 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma3 - end function gsw_sigma3 - - elemental function gsw_sigma4 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma4 - end function gsw_sigma4 - - elemental function gsw_sound_speed (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_sound_speed - end function gsw_sound_speed - - elemental function gsw_sound_speed_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_sound_speed_ice - end function gsw_sound_speed_ice - - elemental function gsw_sound_speed_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_sound_speed_t_exact - end function gsw_sound_speed_t_exact - - elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, & - beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: specvol, alpha, beta - end subroutine gsw_specvol_alpha_beta - - elemental function gsw_specvol_anom_standard (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol_anom_standard - end function gsw_specvol_anom_standard - - elemental function gsw_specvol (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol - end function gsw_specvol - - elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_ct, v_p - end subroutine gsw_specvol_first_derivatives - - elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa, v_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_h - end subroutine gsw_specvol_first_derivatives_wrt_enthalpy - - elemental function gsw_specvol_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_specvol_ice - end function gsw_specvol_ice - - elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - end subroutine gsw_specvol_second_derivatives - - elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa_sa, v_sa_h, v_h_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h - end subroutine gsw_specvol_second_derivatives_wrt_enthalpy - - elemental function gsw_specvol_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_specvol_sso_0 - end function gsw_specvol_sso_0 - - elemental function gsw_specvol_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_specvol_t_exact - end function gsw_specvol_t_exact - - elemental function gsw_sp_from_c (c, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: c, t, p - real (r8) :: gsw_sp_from_c - end function gsw_sp_from_c - - elemental function gsw_sp_from_sa_baltic (sa, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, long, lat - real (r8) :: gsw_sp_from_sa_baltic - end function gsw_sp_from_sa_baltic - - elemental function gsw_sp_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sp_from_sa - end function gsw_sp_from_sa - - elemental function gsw_sp_from_sk (sk) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sk - real (r8) :: gsw_sp_from_sk - end function gsw_sp_from_sk - - elemental function gsw_sp_from_sr (sr) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sr - real (r8) :: gsw_sp_from_sr - end function gsw_sp_from_sr - - elemental function gsw_sp_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sp_from_sstar - end function gsw_sp_from_sstar - - elemental function gsw_spiciness0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness0 - end function gsw_spiciness0 - - elemental function gsw_spiciness1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness1 - end function gsw_spiciness1 - - elemental function gsw_spiciness2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness2 - end function gsw_spiciness2 - - elemental function gsw_sr_from_sp (sp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp - real (r8) :: gsw_sr_from_sp - end function gsw_sr_from_sp - - elemental function gsw_sstar_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sstar_from_sa - end function gsw_sstar_from_sa - - elemental function gsw_sstar_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sstar_from_sp - end function gsw_sstar_from_sp - - elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - end function gsw_t_deriv_chem_potential_water_t_exact - - elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_t_freezing_exact - end function gsw_t_freezing_exact - - elemental function gsw_t_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_t_freezing - end function gsw_t_freezing - - elemental subroutine gsw_t_freezing_first_derivatives (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives - - elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives_poly - - elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(in), optional :: saturation_fraction - logical, intent(in), optional :: polynomial - real (r8) :: gsw_t_freezing_poly - end function gsw_t_freezing_poly - - elemental function gsw_t_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_t_from_ct - end function gsw_t_from_ct - - elemental function gsw_t_from_pt0_ice (pt0_ice, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice, p - real (r8) :: gsw_t_from_pt0_ice - end function gsw_t_from_pt0_ice - - elemental function gsw_thermobaric (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_thermobaric - end function gsw_thermobaric - - pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:) - real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:) - end subroutine gsw_turner_rsubrho - - pure subroutine gsw_util_indx (x, n, z, k) - use gsw_mod_kinds - integer, intent(in) :: n - integer, intent(out) :: k - real (r8), intent(in), dimension(n) :: x - real (r8), intent(in) :: z - end subroutine gsw_util_indx - - pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i) - use gsw_mod_kinds - implicit none - integer, intent(in) :: iy(:) - real (r8), intent(in) :: x(:), x_i(:) - real (r8) :: y_i(size(x_i)) - end function gsw_util_interp1q_int - - pure function gsw_util_sort_real (rarray) result(iarray) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rarray(:) ! Values to be sorted - integer :: iarray(size(rarray)) ! Sorted ids - end function gsw_util_sort_real - - pure function gsw_util_xinterp1 (x, y, n, x0) - use gsw_mod_kinds - implicit none - integer, intent(in) :: n - real (r8), intent(in) :: x0 - real (r8), dimension(n), intent(in) :: x, y - real (r8) :: gsw_util_xinterp1 - end function gsw_util_xinterp1 - - elemental function gsw_z_from_p (p, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, lat - real (r8) :: gsw_z_from_p - end function gsw_z_from_p - -end interface - -end module gsw_mod_toolbox diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 new file mode 120000 index 0000000000..f2f4761ec4 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_toolbox.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 deleted file mode 100644 index 63c2c83292..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 +++ /dev/null @@ -1,59 +0,0 @@ -!========================================================================== -elemental function gsw_pt0_from_t (sa, t, p) -!========================================================================== -! -! Calculates potential temperature with reference pressure, p_ref = 0 dbar. -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt0_from_t : potential temperature, p_ref = 0 [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_entropy_part_zerop -use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_pt0_from_t - -integer n, no_iter -real (r8) :: s1, true_entropy_part, pt0m -real (r8) :: pt0, pt0_old, de_dt, dentropy, dentropy_dt - -s1 = sa/gsw_ups - -pt0 = t + p*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - p * 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - p * 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt0)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt0_old = pt0 - dentropy = gsw_entropy_part_zerop(sa,pt0_old) - true_entropy_part - pt0 = pt0_old - dentropy/dentropy_dt - pt0m = 0.5_r8*(pt0 + pt0_old) - dentropy_dt = -gsw_gibbs_pt0_pt0(sa,pt0m) - pt0 = pt0_old - dentropy/dentropy_dt -end do - -gsw_pt0_from_t = pt0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 new file mode 120000 index 0000000000..79cf5b0d65 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt0_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 deleted file mode 100644 index b856b923c8..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 +++ /dev/null @@ -1,72 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_ct (sa, ct) -!========================================================================== -! -! potential temperature of seawater from conservative temperature -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt_from_ct : potential temperature with [deg C] -! reference pressure of 0 dbar -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0 - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct - -real (r8) :: gsw_pt_from_ct - -real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff -real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1 - -real (r8), parameter :: a0 = -1.446013646344788e-2_r8 -real (r8), parameter :: a1 = -3.305308995852924e-3_r8 -real (r8), parameter :: a2 = 1.062415929128982e-4_r8 -real (r8), parameter :: a3 = 9.477566673794488e-1_r8 -real (r8), parameter :: a4 = 2.166591947736613e-3_r8 -real (r8), parameter :: a5 = 3.828842955039902e-3_r8 - -real (r8), parameter :: b0 = 1.0_r8 -real (r8), parameter :: b1 = 6.506097115635800e-4_r8 -real (r8), parameter :: b2 = 3.830289486850898e-3_r8 -real (r8), parameter :: b3 = 1.247811760368034e-6_r8 - -s1 = sa/gsw_ups - -a5ct = a5*ct -b3ct = b3*ct - -ct_factor = (a3 + a4*s1 + a5ct) -pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor -pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct)) -pt = pt_num*pt_recden - -dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden - -! Start the 1.5 iterations through the modified Newton-Rapshon iterative, -! method, which is also known as the Newton-McDougall method. - -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -pt = pt_old - ct_diff*dpt_dct -ptm = 0.5_r8*(pt + pt_old) - -dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm)) - -pt = pt_old - ct_diff*dpt_dct -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -gsw_pt_from_ct = pt_old - ct_diff*dpt_dct - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 new file mode 120000 index 0000000000..cd794a1316 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_ct.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 deleted file mode 100644 index 46dc766fb6..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 +++ /dev/null @@ -1,61 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_t (sa, t, p, p_ref) -!========================================================================== -! -! Calculates potential temperature of seawater from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! p_ref : reference sea pressure [dbar] -! -! gsw_pt_from_t : potential temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_gibbs - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p, p_ref - -real (r8) :: gsw_pt_from_t - -integer n, no_iter -real (r8) :: s1, pt, pt_old, de_dt, dentropy, dentropy_dt -real (r8) :: true_entropy_part, ptm - -integer, parameter :: n0=0, n2=2 - -s1 = sa/gsw_ups - -pt = t + (p-p_ref)*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - (p+p_ref)* 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - (p+p_ref)* 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt_old = pt - dentropy = gsw_entropy_part(sa,pt_old,p_ref) - true_entropy_part - pt = pt_old - dentropy/dentropy_dt - ptm = 0.5_r8*(pt + pt_old) - dentropy_dt = -gsw_gibbs(n0,n2,n0,sa,ptm,p_ref) - pt = pt_old - dentropy/dentropy_dt -end do - -gsw_pt_from_t = pt - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 new file mode 120000 index 0000000000..37fa5f104f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 deleted file mode 100644 index 3daa65746e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho.f90 +++ /dev/null @@ -1,36 +0,0 @@ -!========================================================================== -elemental function gsw_rho (sa, ct, p) -!========================================================================== -! -! Calculates in-situ density from Absolute Salinity and Conservative -! Temperature, using the computationally-efficient expression for -! specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! Note that potential density with respect to reference pressure, pr, is -! obtained by calling this function with the pressure argument being pr -! (i.e. "gsw_rho(SA,CT,pr)"). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho = in-situ density [ kg/m ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_rho - -gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 new file mode 120000 index 0000000000..22eea6219a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 deleted file mode 100644 index b4ee696a1d..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 +++ /dev/null @@ -1,110 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) -!========================================================================== -! -! Calculates the three (3) partial derivatives of in-situ density with -! respect to Absolute Salinity, Conservative Temperature and pressure. -! Note that the pressure derivative is done with respect to pressure in -! Pa, not dbar. This function uses the computationally-efficient expression -! for specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! drho_dSA = partial derivatives of density [ kg^2/(g m^3) ] -! with respect to Absolute Salinity -! drho_dCT = partial derivatives of density [ kg/(K m^3) ] -! with respect to Conservative Temperature -! drho_dP = partial derivatives of density [ kg/(Pa m^3) ] -! with respect to pressure in Pa -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - -real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -rho2 = (1.0_r8/v)**2 - -if (present(drho_dsa)) then - - v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs - -end if - -if (present(drho_dct)) then - - v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - drho_dct = -rho2*0.025_r8*v_ct - -end if - -if (present(drho_dp)) then - - v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - drho_dp = -rho2*1e-4_r8*pa2db*v_p - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 new file mode 120000 index 0000000000..3a8ba38824 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 deleted file mode 100644 index fdf75e7a0a..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) -!========================================================================== -! -! Calculates five second-order derivatives of rho. Note that this function -! uses the using the computationally-efficient expression for specific -! volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho_SA_SA = The second-order derivative of rho with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! rho_SA_CT = The second-order derivative of rho with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! rho_CT_CT = The second-order derivative of rho with respect to CT at -! constant SA & p -! rho_SA_P = The second-order derivative with respect to SA & P at -! constant CT. -! rho_CT_P = The second-order derivative with respect to CT & P at -! constant SA. -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives -use gsw_mod_toolbox, only : gsw_specvol_second_derivatives - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct -real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - -integer :: iflag1, iflag2 -real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct -real (r8) :: v_sa_p, v_sa_sa - -iflag1 = 0 -if (present(rho_sa_sa) .or. present(rho_sa_ct) & - .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1) -if (present(rho_sa_ct) .or. present(rho_ct_ct) & - .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2) -if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3) - -call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1) - -iflag2 = 0 -if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1) -if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2) -if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3) -if (present(rho_sa_p)) iflag2 = ibset(iflag2,4) -if (present(rho_ct_p)) iflag2 = ibset(iflag2,5) - -call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, & - v_sa_p,v_ct_p,iflag=iflag2) - -rec_v = 1.0_r8/gsw_specvol(sa,ct,p) -rec_v2 = rec_v**2 -rec_v3 = rec_v2*rec_v - -if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3 - -if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3 - -if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3 - -if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3 - -if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3 - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 new file mode 120000 index 0000000000..8b38e0f56f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 deleted file mode 100644 index c01377546c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sp_from_sr (sr) -!========================================================================== -! -! Calculates Practical Salinity, sp, from Reference Salinity, sr. -! -! sr : Reference Salinity [g/kg] -! -! gsw_sp_from_sr : Practical Salinity [unitless] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sr - -real (r8) :: gsw_sp_from_sr - -gsw_sp_from_sr = sr/gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 new file mode 120000 index 0000000000..d8cd41f4bf --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sp_from_sr.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 deleted file mode 100644 index 00cfaab125..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_specvol (sa, ct, p) -!========================================================================== -! -! Calculates specific volume from Absolute Salinity, Conservative -! Temperature and pressure, using the computationally-efficient -! polynomial expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! specvol = specific volume [ m^3/kg ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_specvol - -real (r8) :: xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 new file mode 120000 index 0000000000..7a41a5cea0 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 deleted file mode 100644 index 2f2a006b17..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 +++ /dev/null @@ -1,104 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) -! ========================================================================= -! -! Calculates three first-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA = The first derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_CT = The first derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K(g/kg)) ] -! v_P = The first derivative of specific volume with respect to -! P at constant SA and CT. [ J/(kg K^2) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa, v_ct, v_p - -integer :: i -logical :: flags(3) -real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 3 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa) .and. flags(1)) then - - v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs - -end if - - -if (present(v_ct) .and. flags(2)) then - - v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - v_ct = 0.025_r8*v_ct_part - -end if - -if (present(v_p) .and. flags(3)) then - - v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - v_p = 1e-8_r8*v_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 new file mode 120000 index 0000000000..ee6ee1f906 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 deleted file mode 100644 index 39096109e9..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 +++ /dev/null @@ -1,131 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) -! ========================================================================= -! -! Calculates five second-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA_SA = The second derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_SA_CT = The second derivative of specific volume with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! v_CT_CT = The second derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K^2) ] -! v_SA_P = The second derivative of specific volume with respect to -! SA and P at constant CT. [ J/(kg K(g/kg)) ] -! v_CT_P = The second derivative of specific volume with respect to -! CT and P at constant SA. [ J/(kg K(g/kg)) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - -integer :: i -logical :: flags(5) -real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part -real (r8) :: v_sa_sa_part, xs, xs2, ys, z - -xs2 = gsw_sfac*sa + offset -xs = sqrt(xs2) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 5 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa_sa) .and. flags(1)) then - - v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 & - + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 & - + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) & - + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 & - + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 & - + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 & - + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) & - + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 & - - b013*ys - b004*z))))/xs2 - - v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs - -end if - -if (present(v_sa_ct) .and. flags(2)) then - - v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) & - + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) & - + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) & - + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) & - + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 & - + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs - - v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part - -end if - -if (present(v_ct_ct) .and. flags(3)) then - - v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) & - + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 & - + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 & - + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) & - + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 & - + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) & - + 3.0_r8*a032*ys) + a013*z)) - - v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part - -end if - -if (present(v_sa_p) .and. flags(4)) then - - v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 & - + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) & - + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 & - + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 & - + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) & - + 4.0_r8*b004*z)) - - v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part - -end if - -if (present(v_ct_p) .and. flags(5)) then - - v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 & - + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) & - + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 & - + xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 & - + a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) & - + 4.0_r8*a004*z)) - - v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 new file mode 120000 index 0000000000..cdd1c1b87a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 deleted file mode 100644 index cbcc4fea0b..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sr_from_sp (sp) -!========================================================================== -! -! Calculates Reference Salinity, SR, from Practical Salinity, SP. -! -! sp : Practical Salinity [unitless] -! -! gsw_sr_from_sp : Reference Salinity [g/kg] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sp - -real (r8) :: gsw_sr_from_sp - -gsw_sr_from_sp = sp*gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 new file mode 120000 index 0000000000..eda229ff66 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sr_from_sp.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 deleted file mode 100644 index 668184491f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,88 +0,0 @@ -!========================================================================== -elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the temperature derivative of the chemical potential of water -! in seawater so that it is valid at exactly SA = 0. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_dt = temperature derivative of the chemical -! potential of water in seawater [ J g^-1 K^-1 ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, rec_db2pa - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - -real (r8) :: g03_t, g08_sa_t, x, x2, y, z, g08_t - -real (r8), parameter :: kg2g = 1e-3_r8 - -! Note. The kg2g, a factor of 1e-3, is needed to convert the output of this -! function into units of J/g. See section (2.9) of the TEOS-10 Manual. - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*rec_db2pa ! the input pressure (p) is sea pressure in units of dbar. - -g03_t = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - & - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + & - z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + & - (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - & - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + & - 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - & - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + & - 49.023632509086724_r8*z))))))) - -g08_t = x2*(168.072408311545_r8 + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + & - x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + & - (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + & - z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(3.50240264723578_r8 + 938.26075044542_r8*z))))) - -g08_sa_t = 1187.3715515697959_r8 + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + & - x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + & - y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + & - z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + & - y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) - -gsw_t_deriv_chem_potential_water_t_exact = kg2g*((g03_t + g08_t)*0.025_r8 - & - 0.5_r8*gsw_sfac*0.025_r8*sa*g08_sa_t) -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..3194f69a64 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_deriv_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 deleted file mode 100644 index 63c27db986..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes. The -! in-situ temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_t_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! (i.e., saturation_fraction must be between 0 and 1, and the default -! is 1, completely saturated) -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_freezing_poly - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_t_freezing_exact - -real (r8) :: df_dt, p_r, sa_r, tf, tfm, tf_old, x, f - -! The initial value of t_freezing_exact (for air-free seawater) -tf = gsw_t_freezing_poly(sa,p,polynomial=.true.) - -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) - & - gsw_gibbs_ice(1,0,tf,p) -! df_dt here is the initial value of the derivative of the function f whose -! zero (f = 0) we are finding (see Eqn. (3.33.2) of IOC et al (2010)). - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt -tfm = 0.5_r8*(tf + tf_old) -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tfm,p) - & - gsw_gibbs_ice(1,0,tfm,p) -tf = tf_old - f/df_dt - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt - -! Adjust for the effects of dissolved air -gsw_t_freezing_exact = tf - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 new file mode 120000 index 0000000000..ca5434983f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 deleted file mode 100644 index 479a323d2c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes from a -! computationally efficient polynomial. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -! (ITS-90) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p -real (r8), intent(in), optional :: saturation_fraction -logical, intent(in), optional :: polynomial - -real (r8) :: gsw_t_freezing_poly - -real (r8) :: p_r, sa_r, x, ctf, sfrac -logical :: direct_poly - -if (present(polynomial)) then - direct_poly = polynomial -else - direct_poly = .false. -end if - -if (.not. direct_poly) then - - if (present(saturation_fraction)) then - sfrac = saturation_fraction - else - sfrac = 1.0_r8 - end if - - ctf = gsw_ct_freezing_poly(sa,p,sfrac) - gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p) - -else - - ! Alternative calculation ... - sa_r = sa*1e-2_r8 - x = sqrt(sa_r) - p_r = p*1e-4_r8 - - gsw_t_freezing_poly = t0 & - + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) & - + p_r*(t7 + p_r*(t8 + t9*p_r)) & - + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) & - + sa_r*(t13 + t17*p_r + t19*sa_r) & - + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r))) - - if (.not. present(saturation_fraction)) return - - ! Adjust for the effects of dissolved air - gsw_t_freezing_poly = gsw_t_freezing_poly - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 new file mode 120000 index 0000000000..fcc75a7d80 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 deleted file mode 100644 index 9f85a4530c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!========================================================================== -elemental function gsw_t_from_ct (sa, ct, p) -!========================================================================== -! -! Calculates in-situ temperature from Conservative Temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! -! gsw_t_from_ct : in-situ temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_pt_from_ct, gsw_pt_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_t_from_ct - -real (r8) :: pt0 - -real (r8), parameter :: p0 = 0.0_r8 - -pt0 = gsw_pt_from_ct(sa,ct) -gsw_t_from_ct = gsw_pt_from_t(sa,pt0,p0,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 new file mode 120000 index 0000000000..41a33a07b5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_from_ct.f90 \ No newline at end of file From b31da6a94a0b5f7fe4bc54641a4878c3ae64f2d9 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 18:24:28 +0000 Subject: [PATCH 098/256] Moved pkg/MOM6_DA_hook to config_src/external - Removed two git submodules and added bare interfaces to config_src/exernal/ODA_hooks/ - Added some missing documentation --- .gitmodules | 6 - config_src/external/GFDL_ocean_BGC/README.md | 2 +- config_src/external/ODA_hooks/README.md | 9 ++ config_src/external/ODA_hooks/kdtree.f90 | 12 ++ .../external/ODA_hooks/ocean_da_core.F90 | 90 +++++++++++++ .../external/ODA_hooks/ocean_da_types.F90 | 126 ++++++++++++++++++ .../external/ODA_hooks/write_ocean_obs.F90 | 60 +++++++++ pkg/MOM6_DA_hooks | 1 - pkg/geoKdTree | 1 - src/ocean_data_assim/core | 1 - src/ocean_data_assim/geoKdTree | 1 - 11 files changed, 298 insertions(+), 11 deletions(-) create mode 100644 config_src/external/ODA_hooks/README.md create mode 100644 config_src/external/ODA_hooks/kdtree.f90 create mode 100644 config_src/external/ODA_hooks/ocean_da_core.F90 create mode 100644 config_src/external/ODA_hooks/ocean_da_types.F90 create mode 100644 config_src/external/ODA_hooks/write_ocean_obs.F90 delete mode 160000 pkg/MOM6_DA_hooks delete mode 160000 pkg/geoKdTree delete mode 120000 src/ocean_data_assim/core delete mode 120000 src/ocean_data_assim/geoKdTree diff --git a/.gitmodules b/.gitmodules index b499e43096..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/MOM6_DA_hooks"] - path = pkg/MOM6_DA_hooks - url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git diff --git a/config_src/external/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md index 584e5aa16d..198575c8a7 100644 --- a/config_src/external/GFDL_ocean_BGC/README.md +++ b/config_src/external/GFDL_ocean_BGC/README.md @@ -3,4 +3,4 @@ GFDL_ocean_BGC These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. -The modules in this directory do not do any computations. They simple reflect the APIs of the above package. +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/ODA_hooks/README.md b/config_src/external/ODA_hooks/README.md new file mode 100644 index 0000000000..b26731a463 --- /dev/null +++ b/config_src/external/ODA_hooks/README.md @@ -0,0 +1,9 @@ +ODA_hooks +========= + +These APIs reflect those for the ocean data assimilation hooks similar to https://github.com/MJHarrison-GFDL/MOM6_DA_hooks + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. + +- kdtree.f90 - would come from https://github.com/travissluka/geoKdTree +- ocean_da_core.F90, ocean_da_types.F90, write_ocean_obs.F90 were copied from https://github.com/MJHarrison-GFDL/MOM6_DA_hooks diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 new file mode 100644 index 0000000000..a27716dde1 --- /dev/null +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -0,0 +1,12 @@ +!> A null version of K-d tree from geoKdTree +module kdtree + implicit none + private + + public :: kd_root + + !> A K-d tree tpe + type kd_root + integer :: dummy !< To stop a compiler from doing nothing + end type kd_root +end module kdtree diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 new file mode 100644 index 0000000000..90004bd9d5 --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -0,0 +1,90 @@ +!> A set of dummy interfaces for compiling the MOM6 DA driver code. +module ocean_da_core_mod +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of dummy interfaces for compiling the MOM6 DA +! driver code. These interfaces are not finalized and will be replaced by supported +! interfaces at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use mpp_domains_mod, only : domain2d + use time_manager_mod, only : time_type, set_time, get_date + ! ODA_tools modules + use ocean_da_types_mod, only : ocean_profile_type, grid_type + + + implicit none + private + public :: ocean_da_core_init, open_profile_dataset + public :: get_profiles, copy_profiles + +contains + + !> Initialize ODA + subroutine ocean_da_core_init(Domain, T_grid, Profiles, model_time) + type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain` + type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain + type(ocean_profile_type), pointer :: Profiles + !< This is an unstructured recursive list of profiles + !< which are either within the localized domain corresponding + !< to the Domain argument, or the global profile list + type(time_type), intent(in) :: model_time !< Model time + + Profiles=>NULL() + return + end subroutine ocean_da_core_init + + !> Open a profile dataset + subroutine open_profile_dataset(Profiles, Domain, T_grid, & + filename, time_start, time_end, obs_variable, localize) + type(ocean_profile_type), pointer :: Profiles + !< This is an unstructured recursive list of profiles + !< which are either within the localized domain corresponding + !< to the Domain argument, or the global profile list + type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain + type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain + character(len=*), intent(in) :: filename !< filename containing profile data + type(time_type), intent(in) :: time_start, time_end !< start and end times for the analysis + integer, intent(in), optional :: obs_variable !< If present, then extract corresponding data + !< from file, otherwise, extract all available data which. + logical, intent(in), optional :: localize !< Localize the observations to the current computational domain + + return + + end subroutine open_profile_dataset + + !> Get profiles obs relevant to current analysis interval + subroutine get_profiles(model_time, Profiles, Current_profiles) + type(time_type), intent(in) :: model_time + type(ocean_profile_type), pointer :: Profiles + type(ocean_profile_type), pointer :: Current_profiles + + Profiles=>NULL() + Current_Profiles=>NULL() + + return + end subroutine get_profiles + + !> Copy profiles at current analysis step from a linked list to an array + !! feasible now since the number of localized current profiles is small + subroutine copy_profiles(Current_profiles, Profiles) + type(ocean_profile_type), pointer :: Current_profiles + type(ocean_profile_type), pointer, dimension(:) :: Profiles + + return + + end subroutine copy_profiles + + !> Copy observations + subroutine copy_obs(obs_in, obs_out) + type(ocean_profile_type), pointer :: obs_in + type(ocean_profile_type), pointer :: obs_out + + return + end subroutine copy_obs + +end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 new file mode 100644 index 0000000000..165ed4f4ba --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -0,0 +1,126 @@ +!> This module contains a set of data structures and interfaces for compiling the MOM6 DA +!! driver code. +module ocean_da_types_mod +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of data structures and interfaces for compiling the MOM6 DA +! driver code. This code is not yet finalized and will be replaced by supported +! software at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifndef MAX_LEVS_FILE_ +#define MAX_LEVS_FILE_ 50 +#endif + +#ifndef MAX_LINKS_ +#define MAX_LINKS_ 100 +#endif + +!============================================================ +! This module contains type declarations and default values +! for oda modules. +!============================================================ + +! Contact: Matthew.Harrison@noaa.gov and Feiyu.Lu@noaa.gov + + use time_manager_mod, only : time_type + !use obs_tools_mod, only : obs_def_type + !use mpp_domains_mod, only : domain2d + + implicit none + + private + + integer, parameter, public :: MAX_LEVELS_FILE = MAX_LEVS_FILE_ !< Controls record length for optimal storage + integer, parameter, public :: MAX_LINKS = MAX_LINKS_ !< Maximum number of records per profile for storage for profiles + integer, parameter, public :: UNKNOWN = 0 + + integer, save, public :: TEMP_ID = 1 + integer, save, public :: SALT_ID = 2 + real, parameter, public :: MISSING_VALUE = -1.e10 + + !> Type for ocean state in DA space (same decomposition and vertical grid) + type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size + real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity + integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity + integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH + end type OCEAN_CONTROL_STRUCT + + !> Profile + type, public :: ocean_profile_type + integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) + integer :: inst_type !< instrument types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: nvar !< number of observations types associated with the current profile + real :: project !< e.g. FGGE, COARE, ACCE, ... + real :: probe !< MBT, XBT, drifting buoy + real :: ref_inst !< instrument (thermograph, hull sensor, ...) + integer :: wod_cast_num !< NODC world ocean dataset unique id + real :: fix_depth !< adjust profile depths (for XBT drop rate corrections) + real :: ocn_vehicle !< ocean vehicle type + real :: database_id !< a unique profile id + integer :: levels !< number of levels in the current profile + integer :: basin_mask !<1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + integer :: profile_flag_s !< an overall flag for the profile salinity + real :: lat, lon !< latitude and longitude (degrees E and N) + logical :: accepted !< logical flag to disable a profile + integer :: nlinks !< number of links used to construct the profile (when reading from disk) + type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev=>NULL() + type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev=>NULL() + integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile + real :: nbr_dist ! distance to nearest neighbor model gridpoint + real, dimension(:), pointer :: depth + real, dimension(:), pointer :: data_t => NULL(), data_s => NULL() + real, dimension(:), pointer :: data + !integer, dimension(:), pointer :: flag_t + !integer, dimension(:), pointer :: flag_s ! level-by-level flags for salinity + !::sdu:: For now ECDA use flag as a logical, will likely change in future releases. + logical, dimension(:), pointer :: flag + real :: temp_err, salt_err ! measurement error + !real, dimension(:), pointer :: ms_t ! ms temperature by level + !real, dimension(:), pointer :: ms_s ! ms salinity by level + real, dimension(:), pointer :: ms_inv => NULL() + real, dimension(:), pointer :: ms => NULL() +! type(obs_def_type), dimension(:), pointer :: obs_def => NULL() + type(time_type) :: time + integer :: yyyy + integer :: mmdd + !type(time_type), pointer :: Model_time ! each profile can be associated with a first-guess field with an associated time and grid + !type(grid_type), pointer :: Model_grid + real :: i_index, j_index ! model longitude and latitude indices respectively + real, dimension(:), pointer :: k_index ! model depth indices + type(time_type) :: tdiff ! positive difference between model time and observation time + end type ocean_profile_type + + !> Grid information for ODA purposes, including arrays of + !! lat, lon, depth, thickness, basin and land mask + type, public :: grid_type + real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() + !real, pointer, dimension(:,:) :: x_bound=>NULL(), y_bound=>NULL() + !real, pointer, dimension(:,:) :: dx=>NULL(), dy=>NULL() + real, pointer, dimension(:,:,:) :: z=>NULL() + real, pointer, dimension(:,:,:) :: h=>NULL() + !real, pointer, dimension(:) :: z_bound=>NULL() + !real, pointer, dimension(:) :: dz => NULL() + real, pointer, dimension(:,:) :: basin_mask => NULL() + real, pointer, dimension(:,:,:) :: mask => NULL() + !type(domain2d), pointer :: Dom ! FMS domain type + !logical :: cyclic + integer :: ni, nj, nk + end type grid_type + +end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 new file mode 100644 index 0000000000..468698d475 --- /dev/null +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -0,0 +1,60 @@ +!> Dummy interfaces for writing ODA data +module write_ocean_obs_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of dummy interfaces for compiling the MOM6 DA +! driver code. These interfaces are not finalized and will be replaced by supported +! interfaces at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use ocean_da_types_mod, only : ocean_profile_type + use time_manager_mod, only : time_type, get_time, set_date, operator ( - ) + + implicit none + + private + + public :: open_profile_file, write_profile, close_profile_file, & + write_ocean_obs_init + +contains + +!> Open a profile file +integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) + character(len=*), intent(in) :: name !< File name + integer, intent(in), optional :: nvar !< Number of variables + real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] + real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] + integer, intent(in), optional :: thread !< Thread + integer, intent(in), optional :: fset !< File set + + open_profile_file=-1 +end function open_profile_file + +!> Write a profile +subroutine write_profile(unit,profile) + integer, intent(in) :: unit !< File unit + type(ocean_profile_type), intent(in) :: profile !< Profile + + return +end subroutine write_profile + +!> Close a profile file +subroutine close_profile_file(unit) + integer, intent(in) :: unit !< File unit + + return +end subroutine close_profile_file + +!> Initialize write_ocean_obs module +subroutine write_ocean_obs_init() + + return +end subroutine write_ocean_obs_init + +end module write_ocean_obs_mod diff --git a/pkg/MOM6_DA_hooks b/pkg/MOM6_DA_hooks deleted file mode 160000 index 6d8834ca8c..0000000000 --- a/pkg/MOM6_DA_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 6d8834ca8cf399f1a0d202239d72919907f6cd74 diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index a4670b9743..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a4670b9743c883d310d821eeac5b1f77f587b9d5 diff --git a/src/ocean_data_assim/core b/src/ocean_data_assim/core deleted file mode 120000 index e0a21d3192..0000000000 --- a/src/ocean_data_assim/core +++ /dev/null @@ -1 +0,0 @@ -../../pkg/MOM6_DA_hooks/src/core \ No newline at end of file diff --git a/src/ocean_data_assim/geoKdTree b/src/ocean_data_assim/geoKdTree deleted file mode 120000 index 61fd167bb6..0000000000 --- a/src/ocean_data_assim/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -../../pkg/geoKdTree \ No newline at end of file From 6818402edcc717b9dd78c4b1dcb39ad3d564cce8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 18:35:37 +0000 Subject: [PATCH 099/256] Corrected documentation errors - Updated Doxygen configuration to find files in config_src/external --- config_src/external/ODA_hooks/ocean_da_types.F90 | 10 ++++++---- config_src/external/ODA_hooks/write_ocean_obs.F90 | 2 +- docs/Doxyfile_nortd | 4 +++- docs/Doxyfile_rtd | 4 ++-- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 165ed4f4ba..22041ce76b 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -51,15 +51,16 @@ module ocean_da_types_mod real, pointer, dimension(:,:,:,:) :: S=>NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity - integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity + integer, dimension(:), pointer :: id_t=>NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity + integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH end type OCEAN_CONTROL_STRUCT !> Profile type, public :: ocean_profile_type integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) - integer :: inst_type !< instrument types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: inst_type !< instrument types are defined by platform class + !! (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) integer :: nvar !< number of observations types associated with the current profile real :: project !< e.g. FGGE, COARE, ACCE, ... real :: probe !< MBT, XBT, drifting buoy @@ -99,7 +100,8 @@ module ocean_da_types_mod type(time_type) :: time integer :: yyyy integer :: mmdd - !type(time_type), pointer :: Model_time ! each profile can be associated with a first-guess field with an associated time and grid + !type(time_type), pointer :: Model_time ! each profile can be associated + ! with a first-guess field with an associated time and grid !type(grid_type), pointer :: Model_grid real :: i_index, j_index ! model longitude and latitude indices respectively real, dimension(:), pointer :: k_index ! model depth indices diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index 468698d475..86dcdbab4b 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -31,7 +31,7 @@ integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] integer, intent(in), optional :: thread !< Thread - integer, intent(in), optional :: fset !< File set + integer, intent(in), optional :: fset !< File set open_profile_file=-1 end function open_profile_file diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index e07ce4f0b6..76b66b9dd3 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -794,7 +794,9 @@ INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external + ../config_src/coupled_driver + # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 652f46f076..7a74004d19 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -783,8 +783,8 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric \ - ../config_src/coupled_driver/coupler_util.F90 \ - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external \ + ../config_src/coupled_driver # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses From 9f62a8f11a1b41f96a1d555dcd44e5e9adf23e46 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 21:59:17 +0000 Subject: [PATCH 100/256] Use FMS tag 2019.01.02 in .testing - This version of FMS is a prerequisite to updating calls to FMS ready to try FMS2 I/O behind NOAA-GFDL/SIS2#117 and #1033 --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 5d233d5fb0..29f39e84f1 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.01 +FMS_COMMIT ?= 2019.01.02 FMS := $(DEPS)/fms #--- From 146e5c40dcd39a884e6de4b04c8ba37c4c50a09c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 22 Jun 2020 09:52:36 -0400 Subject: [PATCH 101/256] Doxygen for DA hooks --- .../external/ODA_hooks/ocean_da_core.F90 | 85 +++--------- .../external/ODA_hooks/ocean_da_types.F90 | 129 ++++++------------ .../external/ODA_hooks/write_ocean_obs.F90 | 14 +- src/framework/MOM_domains.F90 | 1 + src/ocean_data_assim/MOM_oda_driver.F90 | 29 +--- 5 files changed, 71 insertions(+), 187 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 index 90004bd9d5..769e44b2aa 100644 --- a/config_src/external/ODA_hooks/ocean_da_core.F90 +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -1,67 +1,41 @@ !> A set of dummy interfaces for compiling the MOM6 DA driver code. module ocean_da_core_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of dummy interfaces for compiling the MOM6 DA -! driver code. These interfaces are not finalized and will be replaced by supported -! interfaces at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpp_domains_mod, only : domain2d - use time_manager_mod, only : time_type, set_time, get_date + ! MOM modules + use MOM_domains, only : MOM_domain_type, domain2D + use MOM_time_manager, only : time_type, set_time, get_date ! ODA_tools modules use ocean_da_types_mod, only : ocean_profile_type, grid_type - + use kdtree, only : kd_root implicit none private - public :: ocean_da_core_init, open_profile_dataset - public :: get_profiles, copy_profiles + public :: ocean_da_core_init + public :: get_profiles contains - !> Initialize ODA - subroutine ocean_da_core_init(Domain, T_grid, Profiles, model_time) - type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain` - type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain - type(ocean_profile_type), pointer :: Profiles - !< This is an unstructured recursive list of profiles - !< which are either within the localized domain corresponding - !< to the Domain argument, or the global profile list - type(time_type), intent(in) :: model_time !< Model time + !> Initializes the MOM6 DA driver code. + subroutine ocean_da_core_init(Domain, global_grid, Profiles, model_time) + type(domain2D), pointer, intent(in) :: Domain !< A MOM domain type + type(grid_type), pointer, intent(in) :: global_grid !< The global ODA horizontal grid type + type(ocean_profile_type), pointer :: Profiles !< This is an unstructured recursive list of profiles + !! which are either within the localized domain corresponding + !! to the Domain argument, or the global profile list (type). + type(time_type), intent(in) :: model_time !< The current model time type. - Profiles=>NULL() - return - end subroutine ocean_da_core_init - !> Open a profile dataset - subroutine open_profile_dataset(Profiles, Domain, T_grid, & - filename, time_start, time_end, obs_variable, localize) - type(ocean_profile_type), pointer :: Profiles - !< This is an unstructured recursive list of profiles - !< which are either within the localized domain corresponding - !< to the Domain argument, or the global profile list - type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain - type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain - character(len=*), intent(in) :: filename !< filename containing profile data - type(time_type), intent(in) :: time_start, time_end !< start and end times for the analysis - integer, intent(in), optional :: obs_variable !< If present, then extract corresponding data - !< from file, otherwise, extract all available data which. - logical, intent(in), optional :: localize !< Localize the observations to the current computational domain + Profiles=>NULL() return + end subroutine ocean_da_core_init - end subroutine open_profile_dataset - !> Get profiles obs relevant to current analysis interval + !> Get profiles obs within the current analysis interval subroutine get_profiles(model_time, Profiles, Current_profiles) - type(time_type), intent(in) :: model_time - type(ocean_profile_type), pointer :: Profiles - type(ocean_profile_type), pointer :: Current_profiles + type(time_type), intent(in) :: model_time !< The current analysis time. + type(ocean_profile_type), pointer :: Profiles !< The full recursive list of profiles. + type(ocean_profile_type), pointer :: Current_profiles !< A returned list of profiles for the + !! current analysis step. Profiles=>NULL() Current_Profiles=>NULL() @@ -69,22 +43,5 @@ subroutine get_profiles(model_time, Profiles, Current_profiles) return end subroutine get_profiles - !> Copy profiles at current analysis step from a linked list to an array - !! feasible now since the number of localized current profiles is small - subroutine copy_profiles(Current_profiles, Profiles) - type(ocean_profile_type), pointer :: Current_profiles - type(ocean_profile_type), pointer, dimension(:) :: Profiles - - return - - end subroutine copy_profiles - - !> Copy observations - subroutine copy_obs(obs_in, obs_out) - type(ocean_profile_type), pointer :: obs_in - type(ocean_profile_type), pointer :: obs_out - - return - end subroutine copy_obs end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 22041ce76b..407342966e 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -1,127 +1,82 @@ -!> This module contains a set of data structures and interfaces for compiling the MOM6 DA -!! driver code. +!> Dummy aata structures and methods for ocean data assimilation. module ocean_da_types_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of data structures and interfaces for compiling the MOM6 DA -! driver code. This code is not yet finalized and will be replaced by supported -! software at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifndef MAX_LEVS_FILE_ -#define MAX_LEVS_FILE_ 50 -#endif -#ifndef MAX_LINKS_ -#define MAX_LINKS_ 100 -#endif - -!============================================================ -! This module contains type declarations and default values -! for oda modules. -!============================================================ - -! Contact: Matthew.Harrison@noaa.gov and Feiyu.Lu@noaa.gov - - use time_manager_mod, only : time_type - !use obs_tools_mod, only : obs_def_type - !use mpp_domains_mod, only : domain2d + use MOM_time_manager, only : time_type implicit none private - integer, parameter, public :: MAX_LEVELS_FILE = MAX_LEVS_FILE_ !< Controls record length for optimal storage - integer, parameter, public :: MAX_LINKS = MAX_LINKS_ !< Maximum number of records per profile for storage for profiles - integer, parameter, public :: UNKNOWN = 0 - integer, save, public :: TEMP_ID = 1 - integer, save, public :: SALT_ID = 2 - real, parameter, public :: MISSING_VALUE = -1.e10 - - !> Type for ocean state in DA space (same decomposition and vertical grid) + !> Example type for ocean ensemble DA state type, public :: OCEAN_CONTROL_STRUCT integer :: ensemble_size - real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity - integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity - integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH end type OCEAN_CONTROL_STRUCT - !> Profile + !> Example of a profile type type, public :: ocean_profile_type - integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) - integer :: inst_type !< instrument types are defined by platform class - !! (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) - integer :: nvar !< number of observations types associated with the current profile - real :: project !< e.g. FGGE, COARE, ACCE, ... - real :: probe !< MBT, XBT, drifting buoy - real :: ref_inst !< instrument (thermograph, hull sensor, ...) - integer :: wod_cast_num !< NODC world ocean dataset unique id - real :: fix_depth !< adjust profile depths (for XBT drop rate corrections) - real :: ocn_vehicle !< ocean vehicle type - real :: database_id !< a unique profile id + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are colocated in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) integer :: levels !< number of levels in the current profile - integer :: basin_mask !<1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, - !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf integer :: profile_flag !< an overall flag for the profile - integer :: profile_flag_s !< an overall flag for the profile salinity real :: lat, lon !< latitude and longitude (degrees E and N) logical :: accepted !< logical flag to disable a profile - integer :: nlinks !< number of links used to construct the profile (when reading from disk) + type(time_type) :: time_window !< The time window associated with this profile [s] + real, pointer, dimension(:) :: obs_error !< The observation error by variable + real :: loc_dist !< The impact radius of this observation (m) type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. type(ocean_profile_type), pointer :: prev=>NULL() type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. type(ocean_profile_type), pointer :: cprev=>NULL() integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile real :: nbr_dist ! distance to nearest neighbor model gridpoint - real, dimension(:), pointer :: depth - real, dimension(:), pointer :: data_t => NULL(), data_s => NULL() - real, dimension(:), pointer :: data - !integer, dimension(:), pointer :: flag_t - !integer, dimension(:), pointer :: flag_s ! level-by-level flags for salinity - !::sdu:: For now ECDA use flag as a logical, will likely change in future releases. - logical, dimension(:), pointer :: flag - real :: temp_err, salt_err ! measurement error - !real, dimension(:), pointer :: ms_t ! ms temperature by level - !real, dimension(:), pointer :: ms_s ! ms salinity by level - real, dimension(:), pointer :: ms_inv => NULL() - real, dimension(:), pointer :: ms => NULL() -! type(obs_def_type), dimension(:), pointer :: obs_def => NULL() - type(time_type) :: time - integer :: yyyy - integer :: mmdd - !type(time_type), pointer :: Model_time ! each profile can be associated - ! with a first-guess field with an associated time and grid - !type(grid_type), pointer :: Model_grid - real :: i_index, j_index ! model longitude and latitude indices respectively - real, dimension(:), pointer :: k_index ! model depth indices - type(time_type) :: tdiff ! positive difference between model time and observation time + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index, j_index !< model longitude and latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename end type ocean_profile_type - !> Grid information for ODA purposes, including arrays of - !! lat, lon, depth, thickness, basin and land mask + !> Example forward operator type. + type, public :: forward_operator_type + integer :: num + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef + end type forward_operator_type + + !> Grid type for DA type, public :: grid_type real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() - !real, pointer, dimension(:,:) :: x_bound=>NULL(), y_bound=>NULL() - !real, pointer, dimension(:,:) :: dx=>NULL(), dy=>NULL() real, pointer, dimension(:,:,:) :: z=>NULL() real, pointer, dimension(:,:,:) :: h=>NULL() - !real, pointer, dimension(:) :: z_bound=>NULL() - !real, pointer, dimension(:) :: dz => NULL() real, pointer, dimension(:,:) :: basin_mask => NULL() real, pointer, dimension(:,:,:) :: mask => NULL() - !type(domain2d), pointer :: Dom ! FMS domain type - !logical :: cyclic + real, pointer, dimension(:,:) :: bathyT => NULL() + logical :: tripolar_N integer :: ni, nj, nk end type grid_type diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index 86dcdbab4b..a2c41b58d6 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -1,26 +1,16 @@ !> Dummy interfaces for writing ODA data module write_ocean_obs_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of dummy interfaces for compiling the MOM6 DA -! driver code. These interfaces are not finalized and will be replaced by supported -! interfaces at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use ocean_da_types_mod, only : ocean_profile_type - use time_manager_mod, only : time_type, get_time, set_date, operator ( - ) + use MOM_time_manager, only : time_type, get_time, set_date implicit none private public :: open_profile_file, write_profile, close_profile_file, & - write_ocean_obs_init + write_ocean_obs_init contains diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 2f31d50607..13bba88271 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -45,6 +45,7 @@ module MOM_domains public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: domain2D !> Do a halo update on an array interface pass_var diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 089e1fc422..acc316cce4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,9 +1,8 @@ !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -! This file is part of MOM6. see LICENSE.md for the license. -use fms_mod, only : open_namelist_file, close_file, check_nml_error -use fms_mod, only : error_mesg, FATAL + ! This file is part of MOM6. see LICENSE.md for the license. + use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use mpp_mod, only : set_root_pe => mpp_set_root_pe @@ -250,20 +249,6 @@ subroutine init_oda(Time, G, GV, CS) allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) - do n=1,CS%ensemble_size - write(fldnam,'(a,i2.2)') 'temp_prior_',n - CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_prior_',n - CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - write(fldnam,'(a,i2.2)') 'temp_posterior_',n - CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_posterior_',n - CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - enddo call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) allocate(CS%oda_grid) @@ -364,10 +349,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) call mpp_redistribute(CS%domains(m)%mpp_domain, S,& CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) - if (CS%Ocean_prior%id_t(m)>0) & - used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) - if (CS%Ocean_prior%id_s(m)>0) & - used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) enddo deallocate(T,S) @@ -478,13 +459,13 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) allocate(CS%T(is:ie,js:je,nk,ens_size)) allocate(CS%S(is:ie,js:je,nk,ens_size)) allocate(CS%SSH(is:ie,js:je,ens_size)) - allocate(CS%id_t(ens_size));CS%id_t(:)=-1 - allocate(CS%id_s(ens_size));CS%id_s(:)=-1 +! allocate(CS%id_t(ens_size));CS%id_t(:)=-1 +! allocate(CS%id_s(ens_size));CS%id_s(:)=-1 ! allocate(CS%U(is:ie,js:je,nk,ens_size)) ! allocate(CS%V(is:ie,js:je,nk,ens_size)) ! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 ! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 - allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 +! allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 return end subroutine init_ocean_ensemble From 804bf1f0c7208ea76af9ea2b5c79cb9346fb9ea1 Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Tue, 23 Jun 2020 17:05:14 -0400 Subject: [PATCH 102/256] added diagnostics for partial derivative of density wrt temperature and salinity --- src/diagnostics/MOM_diagnostics.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e08c920c60..b2848781de 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -134,6 +134,7 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 + integer :: id_drho_dT = -1, id_drho_dS = -1 integer :: id_h_pre_sync = -1 !>@} !> The control structure for calculating wave speed. @@ -619,6 +620,22 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) endif + + if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then + !$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d,h,GV) + 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 + ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d + call calculate_density_derivs(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & + Rcv(:,j,k),work_3d(:,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 + enddo + enddo + if (CS%id_drho_dT > 0) call post_data(CS%id_drho_dT, Rcv, CS%diag) + if (CS%id_drho_dS > 0) call post_data(CS%id_drho_dS, work_3d, CS%diag) + endif endif if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & @@ -1600,6 +1617,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag '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', conversion=US%R_to_kg_m3) + CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', 'kg m-3 degC-1') + CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to salinity (beta)', 'kg^2 g-1 m-3') 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 3f0f0380286c269b3ed83fa02ff8e1d22064e7a5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 23 Jun 2020 21:32:09 -0400 Subject: [PATCH 103/256] Remove "-B" flag from pipeline "make test" - The -B option forced make to make all targets. This was to ensure that everything was remade when work in a shared work space which is no longer the case. We always have a clean work space in these tests and in order to invoke make twice to handle srun errors we can't use the -B option anymore. --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 02c6d15877..1622ae9886 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -116,7 +116,7 @@ run: - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh + - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh - cat log.$CI_PIPELINE_ID - test -f restart_results_gnu.tar.gz From e0071f1e9d30d30ed29265ea3e310c6d1575240f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 24 Jun 2020 09:18:18 -0400 Subject: [PATCH 104/256] Adjusted comments in ODA hooks to fit line length --- config_src/external/ODA_hooks/ocean_da_types.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 407342966e..bc5af1d782 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -23,11 +23,13 @@ module ocean_da_types_mod type, public :: ocean_profile_type integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) logical :: initialized !< a True value indicates that this profile has been allocated for use - logical :: colocated !< a True value indicated that the measurements of (num_variables) data are colocated in space-time + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time integer :: ensemble_size !< size of the ensemble of model states used in association with this profile integer :: num_variables !< number of measurement types associated with this profile. integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module - integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) integer :: levels !< number of levels in the current profile integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, From a7ab5296dfdac7cd3536953955274af14c79e05a Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 23 Mar 2020 14:58:00 -0400 Subject: [PATCH 105/256] This is the minimum required update to use 2020.01 FMS & FMScoupler - Adding domain position arguments to diag_axis_init calls --- src/framework/MOM_diag_mediator.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 368a6b773b..2a71e7cda5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -33,7 +33,7 @@ module MOM_diag_mediator use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_axis_init, diag_field_add_attribute +use diag_manager_mod, only : send_data, diag_axis_init, EAST, NORTH, diag_field_add_attribute ! The following module is needed for PGI since the following line does not compile with PGI 6.5.0 ! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field use MOM_diag_manager_wrapper, only : register_diag_field_fms @@ -365,14 +365,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Horizontal axes for the native grids if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) endif id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain) From 2719400c5a96ff69e3d347f689be6cb3a86b27e5 Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Wed, 24 Jun 2020 22:44:52 -0400 Subject: [PATCH 106/256] fixes import of dens deriv function --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index b2848781de..7d390159bb 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, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, 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 From 424d30db8b7230cc9d63f2b35d6b33cfe97c2396 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 25 Jun 2020 15:32:18 -0400 Subject: [PATCH 107/256] Testing: Removed environment flag checks Due to unpredictable conflicts with flags, the realization that flag testing would launch jobs on Slurm environment, and the fact that Slurm launchers, OpenMPI, and MPICH all appear to pass environment variables on default, we now just assume that "env=val $(MPIRUN)" will pass an environment variable to the MPI job in all cases. This may not be true on all systems, but for now we will assume this works. --- .testing/Makefile | 30 +++++++++--------------------- 1 file changed, 9 insertions(+), 21 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 29f39e84f1..daac0802f2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -268,18 +268,6 @@ $(eval $(call CMP_RULE,regression,symmetric target)) #--- # 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),) -else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$? ; rm -f nv), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) -else - MPIRUN_CMD=$(1) $(MPIRUN) -endif - - # Rule to build work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type @@ -297,20 +285,20 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ - && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> std.err > std.out \ + && $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ - rm ocean.stats chksum_diag ; \ - echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ + rm ocean.stats chksum_diag ; \ + echo -e "${FAIL}: $$*.$(1) failed at runtime." \ ) @echo -e "${DONE}: $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ > work/$$*/codecov.$(1).out \ - 2> work/$$*/codecov.$(1).err ; \ + 2> work/$$*/codecov.$(1).err ; \ fi endef @@ -354,8 +342,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 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." \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # Setup the next inputs cd $(@D) && rm -rf INPUT && mv RESTART INPUT @@ -365,8 +353,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 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." \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics From c95421fe281ca79b7f50dca10e6f35a376f3ed20 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jun 2020 17:16:29 -0400 Subject: [PATCH 108/256] (*)Corrected halo size in EOS call if VERTEX_SHEAR=T Corrected halo size in density derivative calculations in smoothed_dRdT_dRdS This fixes an i-parallelization problem that was recently introduced (as a part of MOM6 PR#1089) when VERTEX_SHEAR is True, and closes MOM6 issue #1146. All answers in the existing MOM6-examples test suite are bitwise identical, but this does change (correct) answers when VERTEX_SHEAR is true. --- src/parameterizations/vertical/MOM_full_convection.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 7bf4a30d3add70e1a6c6531c96bda536e98d492f Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Sat, 27 Jun 2020 23:25:40 -0400 Subject: [PATCH 109/256] Fixing openmp issues with FMS2020 cpu affinity - FMS2020 has newer cpu affinity work. These are mostly to fix the issues with thread placing and hyperthreadng under slurm on gaea. But it also works on Orion. - The new affinity module simplifies the thread-placing calls in the component models. - The name of some functions has changed, that's the reason for crashes like: FATAL: input domain does not have an io_domain. - This update fixes those issues. - openmp runs with 1 and 2 threads gives the same answers as non-openmp - NOTE: I don't rememer why we put the thread placing calls in MOM_domains.F90 They look as unnecessary and the whole #ifndef NOT_SET_AFFINITY block can probably be removed. ocean_nthreads is either set in coupler or solo_driver. --- config_src/solo_driver/MOM_driver.F90 | 25 ++++++++----------------- src/framework/MOM_domains.F90 | 26 +++++--------------------- 2 files changed, 13 insertions(+), 38 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index dfdfeff8ef..6e5115bc62 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -66,6 +66,7 @@ program MOM_main use ensemble_manager_mod, only : ensemble_pelist_setup use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use time_interp_external_mod, only : time_interp_external_init + use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart @@ -207,11 +208,10 @@ program MOM_main character(len=40) :: mod_name = "MOM_main (MOM_driver)" ! This module's name. integer :: ocean_nthreads = 1 - integer :: ncores_per_node = 36 logical :: use_hyper_thread = .false. - integer :: omp_get_num_threads,omp_get_thread_num,get_cpu_affinity,adder,base_cpu + integer :: omp_get_num_threads,omp_get_thread_num namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds,& - ocean_nthreads, ncores_per_node, use_hyper_thread + ocean_nthreads, use_hyper_thread !===================================================================== @@ -252,22 +252,13 @@ program MOM_main endif endif +!$ call fms_affinity_init +!$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (use_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = ncores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() +!$OMP PARALLEL +!$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) -!$OMP END PARALLEL +!$OMP END PARALLEL ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 13bba88271..24dbd0a011 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -30,6 +30,7 @@ module MOM_domains use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get implicit none ; private @@ -1192,7 +1193,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, dimension(4) :: global_indices !$ integer :: ocean_nthreads ! Number of Openmp threads !$ integer :: get_cpu_affinity, omp_get_thread_num, omp_get_num_threads -!$ integer :: omp_cores_per_node, adder, base_cpu !$ logical :: ocean_omp_hyper_thread integer :: nihalo_dflt, njhalo_dflt integer :: pe, proc_used @@ -1274,6 +1274,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() @@ -1285,27 +1286,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ default = 1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ if (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif +!$ call fms_affinity_set('OCEAN', ocean_omp_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() -!!$ call flush(6) -!$OMP END PARALLEL +!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() +!$ call flush(6) !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & From ccd4cbf307cdddceab8bb791ce82d4fc314d9712 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 1 Jul 2020 12:37:00 -0400 Subject: [PATCH 110/256] Testing: Explicit OpenMP CPU affinity FMS affinity operations, often used in OpenMP directives, require explicit CPU affinities such that the number of available CPUs matches the number of requested PEs. To accommodate this, we explicit configure OpenMP to use cpu=0 for our ARM tests. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index daac0802f2..bc03358649 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -310,7 +310,7 @@ $(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(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,openmp,openmp,,,GOMP_CPU_AFFINITY=0,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)) From d64be2073796b4d1e76ddec95d713e8c8394ebc4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Jul 2020 15:05:04 -0400 Subject: [PATCH 111/256] Removed #ifdef debugging blocks Removed old debugging code in blocks of code surrounded by #ifdef statements and removed unnecessary #ifdef around other blocks of debugging code. MOM6 standards discourage the use of CPP macros except for a limited set of uses related to memory where this is unavoidable, so this commit is bringing MOM6 closer to its stated standards. All answers and output are identical. --- .../vertical/MOM_CVMix_KPP.F90 | 6 - .../vertical/MOM_kappa_shear.F90 | 272 ++---------------- .../vertical/MOM_regularize_layers.F90 | 151 +--------- 3 files changed, 26 insertions(+), 403 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f9115b1041..e0889360b9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -627,7 +627,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & real :: LangEnhK ! Langmuir enhancement for mixing coefficient -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) @@ -635,7 +634,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif nonLocalTrans(:,:) = 0.0 @@ -862,12 +860,10 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! j -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif ! send diagnostics to post_data if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) @@ -952,14 +948,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: WST -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) call hchksum(u, "KPP in: u",G%HI,haloshift=0) call hchksum(v, "KPP in: v",G%HI,haloshift=0) endif -#endif ! some constants GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 7db9be0018..096781f8cf 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -19,9 +19,6 @@ module MOM_kappa_shear implicit none ; private #include -#ifdef use_netCDF -#include -#endif public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init public kappa_shear_is_used, kappa_shear_at_vertex @@ -99,9 +96,6 @@ module MOM_kappa_shear ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup -#undef DEBUG -#undef ADD_DIAGNOSTICS - contains !> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns @@ -177,15 +171,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc - ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -195,9 +180,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & dz_massless = 0.1*sqrt(k0dt) !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je do k=1,nz ; do i=is,ie @@ -295,15 +277,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call 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) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -329,18 +305,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(i,K) = 0.0 ; tke_2d(i,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(i,K) = 0.0 ; dz_Int_2d(i,K) = 0.0 -#endif enddo endif ; enddo ! i-loop @@ -348,9 +316,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(i,j,K) = I_Ld2_2d(i,K) ; dz_Int_3d(i,j,K) = dz_Int_2d(i,K) -#endif enddo ; enddo enddo ! end of j-loop @@ -362,10 +327,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calculate_kappa_shear @@ -451,14 +412,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -469,9 +422,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do J=JsB,JeB J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 @@ -597,15 +547,9 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nzc+1 ; kappa(K) = kappa_2d(I,K,J2) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call 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) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then @@ -628,27 +572,16 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(Id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(I,K) = 0.0 ; dz_Int_2d(I,K) = 0.0 -#endif enddo endif ; enddo ! i-loop do K=1,nz+1 ; do I=IsB,IeB tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(I,J,K) = I_Ld2_2d(I,K) ; dz_Int_3d(I,J,K) = dz_Int_2d(I,K) -#endif enddo ; enddo if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec ! Set the diffusivities in tracer columns from the values at vertices. @@ -666,10 +599,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calc_kappa_shear_vertex @@ -794,23 +723,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. integer :: k, itt, itt_dt -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) - real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt - real, dimension(SZK_(GV)+1) :: & - Ri_k, tke_prev, dtke, dkappa, dtke_norm, & - N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] - ksrc_av ! The average through the iterations of k_src [T-1 ~> s-1]. - real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & - tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 - real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & - dkappa_it1, wt_it1, K_Q_it1, d_dkappa_it1, dkappa_norm - real, dimension(SZK_(GV),0:max_debug_itt) :: & - u_it1, v_it1, rho_it1, T_it1, S_it1 - real, dimension(0:max_debug_itt) :: & - dk_wt_it1, dkpos_wt_it1, dkneg_wt_it1, k_mag - real, dimension(max_debug_itt) :: dt_it1 -#endif + + ! This calculation of N2 is for debugging only. + ! real, dimension(SZK_(GV)+1) :: & + ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit gR0 = GV%Rho0 * GV%g_Earth @@ -916,45 +832,12 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif -#ifdef DEBUG - N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 - do K=2,nzc - N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & - dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & - I_dz_int(K), 0.0) - enddo - do k=1,nzc - u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) - T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) - enddo - do K=1,nzc+1 - kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) - tke_it1(K,0) = 0.0 - N2_it1(K,0) = N2_debug(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = K_src(K) - enddo - do k=nzc+1,GV%ke - u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 - T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 - kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 - N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 - enddo - do itt=1,max_debug_itt - dt_it1(itt) = 0.0 - do k=1,GV%ke - u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 - T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 - rho_it1(k,itt) = 0.0 - enddo - do K=1,GV%ke+1 - kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 - N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 - ksrc_it1(K,itt) = 0.0 - dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 - K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 - enddo - enddo - do K=1,GV%ke+1 ; ksrc_av(K) = 0.0 ; enddo -#endif + ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 + ! do K=2,nzc + ! N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + ! dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + ! I_dz_int(K), 0.0) + ! enddo ! This call just calculates N2 and S2. call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, & @@ -981,12 +864,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! ---------------------------------------------------- ! Calculate new values of u, v, rho, N^2 and S. ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) - if (itt > 1) then ; tke_prev(K) = tke(K) ; else ; tke_prev(K) = 0.0 ; endif - enddo -#endif ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & @@ -1099,9 +976,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! This would be here but does nothing. ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt tke_avg(K) = tke_avg(K) + dt_wt*tke(K) -#ifdef DEBUG - tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 -#endif enddo ! call cpu_clock_end(id_clock_avg) else @@ -1157,63 +1031,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_end(id_clock_project) endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - dt_it1(itt) = dt_now - dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 - k_mag(itt) = 0.0 - wt_itt = 1.0/real(itt) ; wt_tot = 0.0 - do K=1,nzc+1 - ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*K_src(K) - wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) - enddo - ! Use the 1/0=0 convention. - I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot - - do K=1,nzc+1 - wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot - k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) - dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) - dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - if (dkappa_it1(K,itt) > 0.0) then - dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - else - dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - endif - wt_it1(K,itt) = wt(K) - enddo - endif - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) - dtke(K) = tke_pred(K) - tke(K) - dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) - dkappa(K) = kappa_pred(K) - kappa_out(K) - enddo - if (itt <= max_debug_itt) then - do k=1,nzc - u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) - T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) - enddo - do K=1,nzc+1 - kprev_it1(K,itt) = kappa_out(K) - kappa_it1(K,itt) = kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) - N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) - ksrc_it1(K,itt) = kappa_src(K) - K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) - if (itt > 1) then - if (abs(dkappa_it1(K,itt-1)) > 1e-20) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - dkappa_norm(K,itt) = dkappa(K) / max(0.5*(kappa_pred(K) + kappa_out(K)), US%m2_s_to_Z2_T*1e-100) - enddo - endif -#endif - if (dt_rem <= 0.0) exit enddo ! end itt loop -#ifdef ADD_DIAGNOSTICS if (present(I_Ld2_1d)) then do K=1,GV%ke+1 ; I_Ld2_1d(K) = 0.0 ; enddo do K=2,nzc ; if (TKE(K) > 0.0) & @@ -1224,7 +1045,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dz_Int_1d(K) = dz_Int(K) ; enddo do K=nzc+2,GV%ke ; dz_Int_1d(K) = 0.0 ; enddo endif -#endif end subroutine kappa_shear_column @@ -1474,18 +1294,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & integer :: ks_kappa, ke_kappa, ke_tke ! The ranges of k-indices that are or integer :: ks_kappa_prev, ke_kappa_prev ! were being worked on. integer :: itt, k, k2 -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) + + ! These variables are used only for debugging. + logical, parameter :: debug_soln = .false. real :: K_err_lin, Q_err_lin, TKE_src_norm real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1,1:max_debug_itt) :: & - tke_it1, kappa_it1, kprev_it1, & ! Various values from each iteration. - dkappa_it1, K_Q_it1, d_dkappa_it1, dkappa_norm_it1 - integer :: it2 -#endif c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 @@ -1529,7 +1345,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! TKE_decay(K) = c_n*sqrt(N2(K)) + c_s*sqrt(S2(K)) ! The expression in JHL. TKE_decay(K) = sqrt(c_n2*N2(K) + c_s2*S2(K)) if ((kappa(K) > 0.0) .and. (K_Q(K) > 0.0)) then - TKE(K) = kappa(K) / K_Q(K) + TKE(K) = kappa(K) / K_Q(K) ! Perhaps take the max with TKE_min else TKE(K) = TKE_min endif @@ -1564,9 +1380,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Calculate TKE ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo -#endif + if (debug_soln) then ; do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo ; endif if (.not.do_Newton) then ! Use separate steps of the TKE and kappa equations, that are @@ -1792,25 +1606,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(ke_kappa+1) = dQ(ke_kappa+1) / (1.0 - cQ(ke_kappa+2)*e1(ke_kappa+2)) TKE(ke_kappa+1) = max(TKE(ke_kappa+1) + dQ(ke_kappa+1), TKE_min) do k=ke_kappa+2,nz+1 -#ifdef DEBUG - if (K < nz+1) then + if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & - (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + ! tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & + ! (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) endif -#endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. dQ(K) = max(e1(K)*dQ(K-1),-0.5*TKE(K)) TKE(K) = max(TKE(K) + dQ(K), TKE_min) if (abs(dQ(K)) < roundoff*TKE(K)) exit enddo -#ifdef DEBUG - do K2=K+1,ke_kappa_prev+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo - do K=K2,nz+1 ; if (dQ(K) == 0.0) exit ; dQ(K) = 0.0 ; dK(K) = 0.0 ; enddo -#endif + if (debug_soln) then ; do K2=K+1,nz+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo ; endif endif if (.not. abort_Newton) then do K=ke_kappa,2,-1 @@ -1837,10 +1646,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 endif -#ifdef DEBUG ! Check these solutions for consistency. ! The unit conversions here have not been carefully tested. - do K=2,nz + if (debug_soln) then ; do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been @@ -1863,8 +1671,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & dz_Int(K) * (dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) - enddo -#endif + enddo ; endif + endif ! End of the Newton's method solver. ! Test kappa for convergence... @@ -1904,34 +1712,10 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & do K=2,nz ; K_Q(K) = kappa(K) / max(TKE(K), TKE_min) ; enddo endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - do K=1,nz+1 - kprev_it1(K,itt) = kappa_prev(K) - kappa_it1(K,itt) = kappa(K) ; tke_it1(K,itt) = tke(K) - dkappa_it1(K,itt) = kappa(K) - kappa_prev(K) - dkappa_norm_it1(K,itt) = (kappa(K) - kappa_prev(K)) / & - (kappa0 + 0.5*(kappa(K) + kappa_prev(K))) - K_Q_it1(K,itt) = kappa(K) / max(TKE(K),TKE_min) - d_dkappa_it1(K,itt) = 0.0 - if (itt > 1) then ; if (abs(dkappa_it1(K,itt-1)) > 1e-20*US%m2_s_to_Z2_T) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - enddo - endif -#endif - if (within_tolerance) exit enddo -#ifdef DEBUG - do it2=itt+1,max_debug_itt ; do K=1,nz+1 - kprev_it1(K,it2) = 0.0 ; kappa_it1(K,it2) = 0.0 ; tke_it1(K,it2) = 0.0 - dkappa_it1(K,it2) = 0.0 ; K_Q_it1(K,it2) = 0.0 ; d_dkappa_it1(K,it2) = 0.0 - enddo ; enddo -#endif - if (do_Newton) then ! K_Q needs to be calculated. do K=1,ks_kappa-1 ; K_Q(K) = 0.0 ; enddo do K=ks_kappa,ke_kappa ; K_Q(K) = kappa(K) / TKE(K) ; enddo @@ -2127,16 +1911,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag - CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear',diag%axesTi,Time, & + CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - CS%id_TKE = register_diag_field('ocean_model','TKE_shear',diag%axesTi,Time, & + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) -#ifdef ADD_DIAGNOSTICS - CS%id_ILd2 = register_diag_field('ocean_model','ILd2_shear',diag%axesTi,Time, & - 'Inverse kappa decay scale at interfaces', 'm-2', conversion=US%m_to_Z**2) - CS%id_dz_Int = register_diag_field('ocean_model','dz_Int_shear',diag%axesTi,Time, & - 'Finite volume thickness of interfaces', 'm', conversion=US%Z_to_m) -#endif end function kappa_shear_init diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index f8a96c894b..f21faa359d 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -18,7 +18,6 @@ module MOM_regularize_layers implicit none ; private #include -#undef DEBUG_CODE public regularize_layers, regularize_layers_init @@ -58,18 +57,6 @@ module MOM_regularize_layers integer :: id_def_rat = -1 !< A diagnostic ID logical :: allow_clocks_in_omp_loops !< If true, clocks can be called from inside loops that !! can be threaded. To run with multiple threads, set to False. -#ifdef DEBUG_CODE - !>@{ Diagnostic IDs - integer :: id_def_rat_2 = -1, id_def_rat_3 = -1 - integer :: id_def_rat_u = -1, id_def_rat_v = -1 - integer :: id_e1 = -1, id_e2 = -1, id_e3 = -1 - integer :: id_def_rat_u_1b = -1, id_def_rat_v_1b = -1 - integer :: id_def_rat_u_2 = -1, id_def_rat_u_2b = -1 - 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 @@ -148,17 +135,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & e ! The interface depths [H ~> m or kg m-2], positive upward. -#ifdef DEBUG_CODE - real, dimension(SZIB_(G),SZJ_(G)) :: & - def_rat_u_1b, def_rat_u_2, def_rat_u_2b, def_rat_u_3, def_rat_u_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_v_1b, def_rat_v_2, def_rat_v_2b, def_rat_v_3, def_rat_v_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_h2, def_rat_h3 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - ef ! The filtered interface depths [H ~> m or kg m-2], positive upward. -#endif - real, dimension(SZI_(G),SZK_(G)+1) :: & e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(G)) :: & @@ -229,12 +205,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_neglect = GV%H_subroundoff debug = (debug .or. CS%debug) -#ifdef DEBUG_CODE - debug = .true. - if (CS%id_def_rat_2 > 0) then ! Calculate over a slightly larger domain. - is = G%isc-1 ; ie = G%iec+1 ; js = G%jsc-1 ; je = G%jec+1 - endif -#endif 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) @@ -249,11 +219,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e(i,j,K+1) = e(i,j,K) - h(i,j,k) enddo ; enddo ; enddo -#ifdef DEBUG_CODE - call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, def_rat_u_1b, def_rat_v_1b, 1, h) -#else call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h=h) -#endif + ! Determine which columns are problematic do j=js,je ; do_j(j) = .false. ; enddo do j=js,je ; do i=is,ie @@ -262,49 +229,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (def_rat_h(i,j) > CS%h_def_tol1) do_j(j) = .true. enddo ; enddo -#ifdef DEBUG_CODE - if ((CS%id_def_rat_3 > 0) .or. (CS%id_e3 > 0) .or. & - (CS%id_def_rat_u_3 > 0) .or. (CS%id_def_rat_u_3b > 0) .or. & - (CS%id_def_rat_v_3 > 0) .or. (CS%id_def_rat_v_3b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - ef(i,j,1) = 0.0 - enddo ; enddo - do K=2,nz+1 ; do j=js,je ; do i=is,ie - if (G%mask2dCu(I,j) <= 0.0) then ; e_e = e(i,j,K) ; else - e_e = max(e(i+1,j,K) + min(e(i,j,K) - e(i+1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCu(I-1,j) <= 0.0) then ; e_w = e(i,j,K) ; else - e_w = max(e(i-1,j,K) + min(e(i,j,K) - e(i-1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J) <= 0.0) then ; e_n = e(i,j,K) ; else - e_n = max(e(i,j+1,K) + min(e(i,j,K) - e(i,j+1,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J-1) <= 0.0) then ; e_s = e(i,j,K) ; else - e_s = max(e(i,j-1,K) + min(e(i,j,K) - e(i,j-1,nz+1), 0.0), e(i,j,nz+1)) - endif - - wt = 1.0 - ef(i,j,k) = (1.0 - 0.5*wt) * e(i,j,K) + & - wt * 0.125 * ((e_e + e_w) + (e_n + e_s)) - enddo ; enddo ; enddo - call find_deficit_ratios(ef, def_rat_u_3, def_rat_v_3, G, GV, CS, def_rat_u_3b, def_rat_v_3b) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h3(i,j) = max(def_rat_u_3(I-1,j), def_rat_u_3(I,j), & - def_rat_v_3(i,J-1), def_rat_v_3(i,J)) - enddo ; enddo - - if (CS%id_e3 > 0) call post_data(CS%id_e3, ef, CS%diag) - if (CS%id_def_rat_3 > 0) call post_data(CS%id_def_rat_3, def_rat_h3, CS%diag) - if (CS%id_def_rat_u_3 > 0) call post_data(CS%id_def_rat_u_3, def_rat_u_3, CS%diag) - if (CS%id_def_rat_u_3b > 0) call post_data(CS%id_def_rat_u_3b, def_rat_u_3b, CS%diag) - if (CS%id_def_rat_v_3 > 0) call post_data(CS%id_def_rat_v_3, def_rat_v_3, CS%diag) - if (CS%id_def_rat_v_3b > 0) call post_data(CS%id_def_rat_v_3b, def_rat_v_3b, CS%diag) - endif -#endif - - ! 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, & @@ -682,40 +606,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (CS%id_def_rat > 0) call post_data(CS%id_def_rat, def_rat_h, CS%diag) -#ifdef DEBUG_CODE - if (CS%id_e1 > 0) call post_data(CS%id_e1, e, CS%diag) - if (CS%id_def_rat_u > 0) call post_data(CS%id_def_rat_u, def_rat_u, CS%diag) - if (CS%id_def_rat_u_1b > 0) call post_data(CS%id_def_rat_u_1b, def_rat_u_1b, CS%diag) - if (CS%id_def_rat_v > 0) call post_data(CS%id_def_rat_v, def_rat_v, CS%diag) - if (CS%id_def_rat_v_1b > 0) call post_data(CS%id_def_rat_v_1b, def_rat_v_1b, CS%diag) - - if ((CS%id_def_rat_2 > 0) .or. & - (CS%id_def_rat_u_2 > 0) .or. (CS%id_def_rat_u_2b > 0) .or. & - (CS%id_def_rat_v_2 > 0) .or. (CS%id_def_rat_v_2b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,1) = 0.0 - enddo ; enddo - do K=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,K+1) = e(i,j,K) - h(i,j,k) - enddo ; enddo ; enddo - - call find_deficit_ratios(e, def_rat_u_2, def_rat_v_2, G, GV, CS, def_rat_u_2b, def_rat_v_2b, h=h) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h2(i,j) = max(def_rat_u_2(I-1,j), def_rat_u_2(I,j), & - def_rat_v_2(i,J-1), def_rat_v_2(i,J)) - enddo ; enddo - - if (CS%id_def_rat_2 > 0) call post_data(CS%id_def_rat_2, def_rat_h2, CS%diag) - if (CS%id_e2 > 0) call post_data(CS%id_e2, e, CS%diag) - if (CS%id_def_rat_u_2 > 0) call post_data(CS%id_def_rat_u_2, def_rat_u_2, CS%diag) - if (CS%id_def_rat_u_2b > 0) call post_data(CS%id_def_rat_u_2b, def_rat_u_2b, CS%diag) - if (CS%id_def_rat_v_2 > 0) call post_data(CS%id_def_rat_v_2, def_rat_v_2, CS%diag) - if (CS%id_def_rat_v_2b > 0) call post_data(CS%id_def_rat_v_2b, def_rat_v_2b, CS%diag) - endif -#endif - end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean @@ -958,45 +848,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) CS%id_def_rat = register_diag_field('ocean_model', 'deficit_ratio', diag%axesT1, & Time, 'Max face thickness deficit ratio', 'nondim') -#ifdef DEBUG_CODE - CS%id_def_rat_2 = register_diag_field('ocean_model', 'deficit_rat2', diag%axesT1, & - Time, 'Corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_3 = register_diag_field('ocean_model', 'deficit_rat3', diag%axesT1, & - Time, 'Filtered thickness deficit ratio', 'nondim') - CS%id_e1 = register_diag_field('ocean_model', 'er_1', diag%axesTi, & - Time, 'Intial interface depths before remapping', 'm') - CS%id_e2 = register_diag_field('ocean_model', 'er_2', diag%axesTi, & - Time, 'Intial interface depths after remapping', 'm') - CS%id_e3 = register_diag_field('ocean_model', 'er_3', diag%axesTi, & - Time, 'Intial interface depths filtered', 'm') - - CS%id_def_rat_u = register_diag_field('ocean_model', 'defrat_u', diag%axesCu1, & - Time, 'U-point thickness deficit ratio', 'nondim') - CS%id_def_rat_u_1b = register_diag_field('ocean_model', 'defrat_u_1b', diag%axesCu1, & - Time, 'U-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2 = register_diag_field('ocean_model', 'defrat_u_2', diag%axesCu1, & - Time, 'U-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2b = register_diag_field('ocean_model', 'defrat_u_2b', diag%axesCu1, & - Time, 'U-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3 = register_diag_field('ocean_model', 'defrat_u_3', diag%axesCu1, & - Time, 'U-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3b = register_diag_field('ocean_model', 'defrat_u_3b', diag%axesCu1, & - Time, 'U-point filtered 2-layer thickness deficit ratio', 'nondim') - - CS%id_def_rat_v = register_diag_field('ocean_model', 'defrat_v', diag%axesCv1, & - Time, 'V-point thickness deficit ratio', 'nondim') - CS%id_def_rat_v_1b = register_diag_field('ocean_model', 'defrat_v_1b', diag%axesCv1, & - Time, 'V-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2 = register_diag_field('ocean_model', 'defrat_v_2', diag%axesCv1, & - Time, 'V-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2b = register_diag_field('ocean_model', 'defrat_v_2b', diag%axesCv1, & - Time, 'V-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3 = register_diag_field('ocean_model', 'defrat_v_3', diag%axesCv1, & - Time, 'V-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3b = register_diag_field('ocean_model', 'defrat_v_3b', diag%axesCv1, & - Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') -#endif - if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif From af55cce17ee655dde99b167deae34f452e4cea9d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 30 Jun 2020 18:26:03 -0800 Subject: [PATCH 112/256] OBC code for slope_x, slope_y. --- src/core/MOM.F90 | 8 +- src/core/MOM_isopycnal_slopes.F90 | 44 +++++++++- .../lateral/MOM_lateral_mixing_coeffs.F90 | 84 ++++++++++++++----- src/user/Kelvin_initialization.F90 | 27 +++--- 4 files changed, 122 insertions(+), 41 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 15d8e5222d..4a98dbea6f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -994,7 +994,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) 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) @@ -1067,7 +1067,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1479,7 +1479,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1505,7 +1505,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index fa60fb821d..b0a66b9488 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -8,6 +8,8 @@ module MOM_isopycnal_slopes 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_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -24,7 +26,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return N2 used in calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, halo, OBC) !, eta_to_m) 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 @@ -44,6 +46,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. @@ -102,6 +105,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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 + logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -118,6 +122,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & L_to_Z = 1.0 / Z_to_L dz_neglect = GV%H_subroundoff * H_to_Z + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + use_EOS = associated(tv%eqn_of_state) present_N2_u = PRESENT(N2_u) @@ -167,7 +178,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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 present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC) & !$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, & @@ -247,6 +258,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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) endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif + slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + endif enddo ! I enddo ; enddo ! end of j-loop @@ -256,7 +280,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! 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,EOSdom_v) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & + !$OMP local_open_v_BC) & !$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, & @@ -333,6 +358,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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) endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif + slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + endif enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 0f07701eda..c227bdfdb7 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -3,20 +3,21 @@ module MOM_lateral_mixing_coeffs ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data -use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled -use MOM_domains, only : create_group_pass, do_group_pass -use MOM_domains, only : group_pass_type, pass_var, pass_vector -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass +use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_interface_heights, only : find_eta -use MOM_isopycnal_slopes, only : calc_isoneutral_slopes -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_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +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_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_open_boundary, only : ocean_OBC_type implicit none ; private @@ -432,7 +433,7 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: 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 @@ -440,6 +441,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. @@ -453,12 +455,12 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, 1) - call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) + call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) endif endif @@ -476,7 +478,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) +subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -488,6 +490,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) !! at v-points [T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [nondim] @@ -500,6 +503,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -511,6 +515,13 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + S2max = CS%Visbeck_S_max**2 !$OMP parallel do default(shared) @@ -523,7 +534,8 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. - !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & + !$OMP local_open_u_BC) do j = js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. @@ -556,10 +568,16 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_u(I,j) = 0. endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + CS%SN_u(i,J) = 0. + endif + endif enddo enddo - !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & + !$OMP local_open_u_BC) do J = js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. @@ -592,6 +610,11 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_v(i,J) = 0. endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif + endif enddo enddo @@ -613,7 +636,7 @@ end subroutine calc_Visbeck_coeffs !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -622,6 +645,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position [Z ~> m] logical, intent(in) :: calculate_slopes !< If true, calculate slopes internally !! otherwise use slopes stored in CS + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) @@ -637,6 +661,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop integer :: i, j, k, kb_max real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -648,6 +673,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) @@ -723,6 +755,11 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_u(I,j) = 0.0 endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + CS%SN_u(I,j) = 0. + endif + endif enddo enddo !$OMP parallel do default(shared) @@ -740,6 +777,11 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_v(I,j) = 0.0 endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif + endif enddo enddo diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index a3215294fc..227c814b3c 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -242,20 +242,21 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + ! Use inside bathymetry + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) 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)))) ) + (G%bathyT(i+1,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)))) ) + (G%bathyT(i+1,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)))) ) + (G%bathyT(i+1,j) )) ) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo endif @@ -285,16 +286,16 @@ 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 - cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + cff =sqrt(GV%g_Earth * G%bathyT(i+1,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))) ) + ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) enddo ; endif enddo ; enddo endif - else + else ! Must be south isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied @@ -303,20 +304,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) 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 + (G%bathyT(i,j+1) )) * 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 + (G%bathyT(i,j+1) )) * 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 + (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo endif @@ -344,11 +345,11 @@ 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 - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) 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))) )) + ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) enddo ; endif enddo ; enddo endif From 650683ce9425e2e173bd40404e1f23abcf535f72 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Jul 2020 07:46:17 -0400 Subject: [PATCH 113/256] +Aligned newlines with module documentation Modified doc_module so that new lines are added only when modules are documented, and are added in all parameter_doc files in which modules are documented. All answers and output are identical, but there are white space changes in MOM_parameter_doc and SIS_parameter_doc files. --- src/framework/MOM_document.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 1a732533b0..28ba9c1ac1 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -776,7 +776,9 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de call open_doc_file(doc) if (doc%filesAreOpen) then - call writeMessageAndDesc(doc, '', '') ! Blank line for delineation + ! Add a blank line for delineation + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default, & + layoutParam=layoutMod, debuggingParam=debuggingMod) mesg = "! === module "//trim(modname)//" ===" call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0, & layoutParam=layoutMod, debuggingParam=debuggingMod) @@ -786,8 +788,10 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de repeat_doc = .false. if (present(layoutMod)) then ; if (layoutMod) repeat_doc = .true. ; endif if (present(debuggingMod)) then ; if (debuggingMod) repeat_doc = .true. ; endif - if (repeat_doc) & + if (repeat_doc) then + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default) call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0) + endif endif ; endif endif end subroutine doc_module From 515f3292cc34c0a7d9ab9f2f18752c83c1073df2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 10:19:28 -0800 Subject: [PATCH 114/256] Added halo updates for OBC radiation speeds. --- src/core/MOM_open_boundary.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bf3d24a790..c0e64db491 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,7 +9,7 @@ module MOM_open_boundary use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector -use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, CORNER 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 @@ -1598,6 +1598,11 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & + To_All+Scalar_Pair) + if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to From 2c1864998181c77f699657db76f9701b51dda98e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 19:28:12 -0800 Subject: [PATCH 115/256] Fixing the OMP issue? --- src/core/MOM_isopycnal_slopes.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index b0a66b9488..84df62b801 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -281,7 +281,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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,EOSdom_v, & - !$OMP local_open_v_BC) & + !$OMP local_open_v_BC,OBC%segnum_u,OBC%segnum_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, & From 209389a99b72ad8f973d4c4300bf7f1bbbdd521b Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 19:31:35 -0800 Subject: [PATCH 116/256] Was hoping this would fix flux_y, but no. --- src/tracer/MOM_tracer_advect.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5868d60b46..6a362d4fd5 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -459,13 +459,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -913,7 +913,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif ! Implementation of PPM-H3 - Tp = Tr(m)%t(i,j_up+1,k) ; Tc = Tr(m)%t(i,j_up,k) ; Tm = Tr(m)%t(i,j_up-1,k) + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) if (useHuynh) then aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate @@ -955,7 +955,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j,k) + Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) ! Original implementation of PLM !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) @@ -968,7 +968,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j+1,k) + Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) ! Original implementation of PLM !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) From d1cd69623b93625127b1399d38fed372100f5255 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Jul 2020 04:03:30 -0400 Subject: [PATCH 117/256] +Add like_default optional argument to log_param Added the new optional argument like_default to the log_param and doc_param routines to help control where the documentation appears. This new argument is used for logging EPBL_USTAR_MIN, the diagnosed output value of MAXIMUM_DEPTH when the input value is negative, and the diagnosed number of columns where sponges occur with MOM_ALE_sponge. An '!' was also added to the logging of EPBL_USTAR_MIN. All answers are bitwise identical but there are minor changes in the contents of some MOM_parameter_doc.short files. --- src/framework/MOM_document.F90 | 42 ++++++++++++---- src/framework/MOM_file_parser.F90 | 50 ++++++++++++------- .../MOM_fixed_initialization.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 12 ++--- .../vertical/MOM_energetic_PBL.F90 | 5 +- 5 files changed, 75 insertions(+), 36 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 28ba9c1ac1..15d0839ee9 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -85,7 +85,7 @@ end subroutine doc_param_none !> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -95,6 +95,8 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & logical, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -110,6 +112,7 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val .eqv. default) equalsDefault = .true. if (default) then @@ -127,7 +130,7 @@ end subroutine doc_param_logical !> This subroutine handles parameter documentation for arrays of logicals. subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -137,6 +140,8 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & logical, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -158,7 +163,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = define_string(doc, varname, valstring, units) - equalsDefault = .false. + equalsDefault = .false. if (present(default)) then equalsDefault = .true. do i=1,size(vals) ; if (vals(i) .neqv. default) equalsDefault = .false. ; enddo @@ -168,6 +173,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = trim(mesg)//" default = "//STRING_FALSE endif endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -177,7 +183,7 @@ end subroutine doc_param_logical_array !> This subroutine handles parameter documentation for integers. subroutine doc_param_int(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -187,6 +193,8 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & integer, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -200,6 +208,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//(trim(int_string(default))) @@ -213,7 +222,7 @@ end subroutine doc_param_int !> This subroutine handles parameter documentation for arrays of integers. subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -223,6 +232,8 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & integer, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -246,6 +257,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//(trim(int_string(default))) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -255,7 +267,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & end subroutine doc_param_int_array !> This subroutine handles parameter documentation for reals. -subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam, like_default) 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 @@ -264,6 +276,8 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara real, intent(in) :: val !< The value of this parameter real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -277,6 +291,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(real_string(default)) @@ -288,7 +303,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara end subroutine doc_param_real !> This subroutine handles parameter documentation for arrays of reals. -subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) 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 @@ -297,6 +312,8 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg real, intent(in) :: vals(:) !< The array of values to record real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -317,6 +334,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//trim(real_string(default)) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) @@ -326,7 +344,7 @@ end subroutine doc_param_real_array !> This subroutine handles parameter documentation for character strings. subroutine doc_param_char(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -337,6 +355,8 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -348,6 +368,7 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, '"'//trim(val)//'"', units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (trim(val) == trim(default)) equalsDefault = .true. mesg = trim(mesg)//' default = "'//trim(adjustl(default))//'"' @@ -412,7 +433,7 @@ 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, val, default, units, debuggingParam) +subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam, like_default) 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 @@ -421,6 +442,8 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara type(time_type), optional, intent(in) :: default !< The default value of this 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! Local varables character(len=mLen) :: mesg ! The output message @@ -439,6 +462,7 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(time_string(default)) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index a07d828e5b..2e7a14dbe4 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1289,7 +1289,7 @@ end subroutine log_version_plain !> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1303,6 +1303,8 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1315,13 +1317,13 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int !> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1335,6 +1337,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1348,13 +1352,13 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int_array !> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default, debuggingParam) + default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1366,6 +1370,8 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1379,13 +1385,13 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real !> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam) + units, default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1397,6 +1403,8 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1414,13 +1422,13 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real_array !> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1434,6 +1442,8 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1450,13 +1460,13 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_logical !> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1470,6 +1480,8 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1483,14 +1495,14 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_char !> This subroutine writes the value of a time-type parameter to a log file, !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & - default, timeunit, layoutParam, debuggingParam, log_date) + default, timeunit, layoutParam, debuggingParam, log_date, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1508,6 +1520,8 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. ! Local variables real :: real_time, real_default @@ -1543,10 +1557,10 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & default_string = convert_date_to_string(default) call doc_param(CS%doc, varname, desc, myunits, date_string, & default=default_string, layoutParam=layoutParam, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) else call doc_param(CS%doc, varname, desc, myunits, date_string, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) endif elseif (use_timeunit) then if (present(units)) then @@ -1566,12 +1580,12 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & real_default = (86400.0/timeunit)*days + secs/timeunit if (ticks > 0) real_default = real_default + & real(ticks) / (timeunit*get_ticks_per_second()) - call doc_param(CS%doc, varname, desc, myunits, real_time, real_default) + call doc_param(CS%doc, varname, desc, myunits, real_time, real_default, like_default=like_default) else - call doc_param(CS%doc, varname, desc, myunits, real_time) + call doc_param(CS%doc, varname, desc, myunits, real_time, like_default=like_default) endif else - call doc_param(CS%doc, varname, desc, value, default, units=units) + call doc_param(CS%doc, varname, desc, value, default, units=units, like_default=like_default) endif endif diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 1ddf6f2345..b075da4141 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -249,7 +249,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) else max_depth = diagnoseMaximumDepth(D,G) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m") + "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) endif if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth, US) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 5088a92d6e..27aa43274b 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -256,7 +256,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then @@ -300,7 +300,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 @@ -336,7 +336,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_fixed @@ -484,7 +484,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & 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.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) 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 @@ -513,7 +513,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -538,7 +538,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_varying diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 32c2797394..5a9e67bfd9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2339,9 +2339,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") + "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + like_default=.true.) !/ Checking output flags From e9c1f6c7e726ff9e9c7067cc15346d43db66dcce Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Fri, 3 Jul 2020 09:55:35 -0400 Subject: [PATCH 118/256] altered OpenMP directive for diagnostic --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7d390159bb..f26e7fc815 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -622,7 +622,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then - !$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d,h,GV) + !$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 From 029af686e9453f2671bbf622fd44fc366415d818 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Jul 2020 06:29:38 -0400 Subject: [PATCH 119/256] +Set all_default for 4 log_version calls Added code to determine whether all parameters in the MOM_grid, MOM_restart, MOM_write_cputime and MOM_tracer_registry modules are being used with their default settings, and added all_default arguments to the log_version calls for these modules. All answers and output are identical, but there are white space changes in MOM_parameter_doc.short and SIS_parameter_doc.short files. --- src/core/MOM_grid.F90 | 4 ++-- src/framework/MOM_restart.F90 | 22 +++++++++++++++++++--- src/framework/MOM_write_cputime.F90 | 13 ++++++++++--- src/tracer/MOM_tracer_registry.F90 | 2 +- 4 files changed, 32 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f6c8b44986..8844c65f40 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -210,10 +210,10 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) call log_version(param_file, mod_nm, version, & "Parameters providing information about the lateral grid.", & - log_to_all=.true., layout=.true.) - + log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) call get_param(param_file, mod_nm, "NIBLOCK", niblock, "The number of blocks "// & "in the x-direction on each processor (for openmp).", default=1, & diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..ed29b99b55 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1511,6 +1511,7 @@ subroutine restart_init(param_file, CS, restart_root) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (associated(CS)) then call MOM_error(WARNING, "restart_init called with an associated control structure.") @@ -1518,10 +1519,25 @@ subroutine restart_init(param_file, CS, restart_root) endif allocate(CS) + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + default=.true., do_not_log=.true.) + all_default = ((.not.CS%parallel_restartfiles) .and. (CS%large_file_support) .and. & + (CS%max_fields == 100) .and. (CS%checksum_required)) + if (.not.present(restart_root)) then + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + default="MOM.res", do_not_log=.true.) + all_default = (all_default .and. (trim(CS%restartfile) == trim("MOM.res"))) + endif + ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & - CS%parallel_restartfiles, & + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 7a2fb36608..1f0e001073 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -60,9 +60,10 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Local variables integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = 'MOM_write_cputime' ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (.not.associated(CS)) then allocate(CS) @@ -71,7 +72,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) + all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) + + call log_version(param_file, mdl, version, "", all_default=all_default) call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & "The maximum amount of cpu time per processor for which "//& "MOM should run before saving a restart file and "//& diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 16ee280355..5097501b61 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -869,7 +869,7 @@ subroutine tracer_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", all_default=.true.) init_calls = init_calls + 1 if (init_calls > 1) then From 153417fbb95d056e7085dceb8c8d6f2745fd845b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 6 Jul 2020 14:20:52 -0400 Subject: [PATCH 120/256] Correted OMP directives for two OBC variables - Members of a type cannot be individually labelled as shared/private - One variable was converted to shared since it was defiend in a non-OMP section and then labelled as private which meant it was uninitialized. --- src/core/MOM_isopycnal_slopes.F90 | 5 +++-- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 6 ++---- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 84df62b801..58bc196744 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -178,7 +178,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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,local_open_u_BC) & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & + !$OMP OBC) & !$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, & @@ -281,7 +282,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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,EOSdom_v, & - !$OMP local_open_v_BC,OBC%segnum_u,OBC%segnum_v) & + !$OMP local_open_v_BC,OBC) & !$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, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index c227bdfdb7..e0def91821 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -534,8 +534,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. - !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & - !$OMP local_open_u_BC) + !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) do j = js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. @@ -576,8 +575,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O enddo enddo - !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & - !$OMP local_open_u_BC) + !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) do J = js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. From 5736bcf90a4b2f3aba0d88d31e5204ff838d1a3e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 11:41:52 -0400 Subject: [PATCH 121/256] Fixed trailing whtiespace for #1148 --- config_src/solo_driver/MOM_driver.F90 | 4 ++-- src/framework/MOM_domains.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 6e5115bc62..f180cd9717 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -252,13 +252,13 @@ program MOM_main endif endif -!$ call fms_affinity_init +!$ call fms_affinity_init !$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) !$OMP PARALLEL !$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) -!$OMP END PARALLEL +!$OMP END PARALLEL ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 24dbd0a011..7cf9df39f1 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1274,7 +1274,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call fms_affinity_init +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() From 50197105372fa8e5a4ab053173f7d70f2a5e0f8b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 30 Apr 2020 16:26:24 +0000 Subject: [PATCH 122/256] Adds the Stanley version of EOS - Stanley et al., 2020, adds the Brankart modification to volume mean density via linear corrections involving SGS sample variances and covariances of T and S. This commit adds the new interfaces that allow a call to calculate_density to include the variances and covariance as arguments. This correction sits above the particular EOS and thus can use any EOS so long as second derivatives are available within the EOS module. --- src/equation_of_state/MOM_EOS.F90 | 152 ++++++++++++++++++++++++++++++ 1 file changed, 152 insertions(+) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c584b68c89..44d34ce475 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -60,6 +60,8 @@ 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_1d + module procedure calculate_stanley_density_scalar, calculate_stanley_density_array + module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P @@ -193,6 +195,43 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) end subroutine calculate_density_scalar +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The +!! density can be rescaled using rho_ref. +subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, 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) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, intent(in) :: Svar !< Variance of salinity [ppt2] + 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, 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] + ! Local variables + real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_scalar called with an unassociated EOS_type EOS.") + + ! Branching to the correct EOS happens within each of these calls + ! and will appropriately error if the second derivatives are not available. + call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, EOS) + call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + + ! Equation 25 of Stanley et al., 2020. + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) + + if (present(scale)) rho = scale * rho + +end subroutine calculate_stanley_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) @@ -234,6 +273,49 @@ 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 +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, 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(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + 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] + ! Local variables + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: j + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_array called with an unassociated EOS_type EOS.") + + ! Branching to the correct EOS happens within each of these calls + ! and will appropriately error if the second derivatives are not available. + call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, start, npts, EOS) + call calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) + + ! Equation 25 of Stanley et al., 2020. + do j=start,start+npts-1 + rho(j) = rho(j) + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + enddo + + 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_stanley_density_array + !> 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. @@ -288,6 +370,75 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) end subroutine calculate_density_1d +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S, +!! potentially limiting the domain of indices that are worked on. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, EOS, 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(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + 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 + 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 :: 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] + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: i, is, ie, npts + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_1d called with an unassociated EOS_type EOS.") + + 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 + + p_scale = EOS%RL2_T2_to_Pa + rho_unscale = EOS%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) + call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, is, npts, EOS) + else ! 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 + call calculate_density_second_derivs_array(T, S, pres, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, is, npts, EOS) + if (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. + 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. + call calculate_density_array(T, S, pres, rho, is, npts, EOS) + endif + endif + do i=is,ie + rho(i) = rho(i) + ( d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + d2RdSS(i) * Svar(i) ) ) + enddo + + 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 + rho(i) = rho_scale * rho(i) + enddo ; endif + +end subroutine calculate_stanley_density_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) @@ -2166,6 +2317,7 @@ 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 +stop if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else From 3006b9c4979ddd76f30cd126ccdd9c0537e2dca3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 30 Apr 2020 17:12:30 +0000 Subject: [PATCH 123/256] Renamed pressure_gradient_plm() to TS_PLM_edge_values() - The routines pressure_gradient_plm() and pressure_gradient_ppm() were poorly named and had comments referring to the pressure gradient calculation even though the only calculate edge values in the vertical for T/S using ALE functions. The routines are actually more general and can be used outside of the PGF. The comments have been shortened and no longer refer to the PGF. --- src/ALE/MOM_ALE.F90 | 27 +++++------- src/core/MOM_PressureForce_analytic_FV.F90 | 41 +++---------------- .../MOM_state_initialization.F90 | 4 +- 3 files changed, 18 insertions(+), 54 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c4bf6ea7f0..1d9c66001b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -110,8 +110,8 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar -public pressure_gradient_plm -public pressure_gradient_ppm +public TS_PLM_edge_values +public TS_PPM_edge_values public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -1006,12 +1006,9 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c end subroutine ALE_remap_scalar -!> Use plm reconstruction for pressure gradient (determine edge values) -!! By using a PLM (limited piecewise linear method) reconstruction, this -!! routine determines the edge values for the salinity and temperature -!! within each layer. These edge values are returned and are used to compute -!! the pressure gradient (by computing the densities). -subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1078,15 +1075,11 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_plm +end subroutine TS_PLM_edge_values - -!> Use ppm reconstruction for pressure gradient (determine edge values) -!> By using a PPM (limited piecewise linear method) reconstruction, this -!> routine determines the edge values for the salinity and temperature -!> within each layer. These edge values are returned and are used to compute -!> the pressure gradient (by computing the densities). -subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1168,7 +1161,7 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_ppm +end subroutine TS_PPM_edge_values !> Initializes regridding for the main ALE algorithm diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 59214dd914..03ed0def88 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -18,13 +18,13 @@ module MOM_PressureForce_AFV 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 +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private #include -public PressureForce_AFV, PressureForce_AFV_init, PressureForce_AFV_end +public PressureForce_AFV_init, PressureForce_AFV_end public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -61,35 +61,6 @@ module MOM_PressureForce_AFV contains -!> Thin interface between the model and the Boussinesq and non-Boussinesq -!! pressure force routines. -subroutine PressureForce_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_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_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - endif - -end subroutine PressureForce_AFV - !> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient !! !! Determines the acceleration due to hydrostatic pressure forces, using @@ -251,9 +222,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! 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) + call TS_PLM_edge_values(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) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -628,9 +599,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! 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) + call TS_PLM_edge_values(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) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 33929737a7..6ca98da171 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -40,7 +40,6 @@ module MOM_state_initialization use MOM_unit_scaling, only : unit_scale_type 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, 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 @@ -91,6 +90,7 @@ module MOM_state_initialization 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_ALE, only : TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main use MOM_remapping, only : remapping_CS, initialize_remapping @@ -1149,7 +1149,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) ! Find edge values of T and S used in reconstructions if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec From 7e8ac759cf12afb79abdc1510f93674090e09ee7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 1 May 2020 18:43:44 +0000 Subject: [PATCH 124/256] Break out density integrals into a new module - The integrals of density routines used (mostly) by the PGF calculation were part of MOM_EOS. Originally, when writing the analytic FV PGF paper, this was the right place to put the integrals. The additional variants using the ALE reconstruction functions mean that it is cleaner to have these routines sit in a layer above EOS and ALE. --- src/core/MOM_PressureForce_Montgomery.F90 | 5 +- src/core/MOM_PressureForce_analytic_FV.F90 | 18 +- src/core/MOM_density_integrals.F90 | 1725 +++++++++++++++++ src/core/MOM_interface_heights.F90 | 6 +- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 5 +- src/equation_of_state/MOM_EOS.F90 | 1293 +----------- .../MOM_state_initialization.F90 | 5 +- .../MOM_tracer_initialization_from_Z.F90 | 2 +- 9 files changed, 1766 insertions(+), 1295 deletions(-) create mode 100644 src/core/MOM_density_integrals.F90 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 99268460df..07cbf3adf4 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_Mont ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_density_integrals, only : int_specific_vol_dp 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, MOM_mesg, FATAL, WARNING, is_root_pe @@ -13,7 +14,7 @@ module MOM_PressureForce_Mont 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_specific_vol_dp, query_compressible +use MOM_EOS, only : query_compressible implicit none ; private @@ -188,7 +189,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) + 0.0, G%HI, tv%eqn_of_state, US, 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 diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 03ed0def88..05dac0c0c3 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -14,10 +14,10 @@ module MOM_PressureForce_AFV 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_density_integrals, only : int_density_dz, int_specific_vol_dp +use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_density_integrals, only : int_spec_vol_dp_generic_plm +use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private @@ -237,7 +237,7 @@ 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), & + tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& @@ -250,7 +250,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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), & + US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp=CS%useMassWghtInterp) endif @@ -642,17 +642,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, tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, tv%eqn_of_state, US, 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, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, 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, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, 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_density_integrals.F90 b/src/core/MOM_density_integrals.F90 new file mode 100644 index 0000000000..4cd9c8fc48 --- /dev/null +++ b/src/core/MOM_density_integrals.F90 @@ -0,0 +1,1725 @@ +!> Provides integrals of density +module MOM_density_integrals + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : calculate_density_second_derivs + +use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear +use MOM_EOS_linear, only : calculate_density_derivs_linear +use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear +use MOM_EOS_linear, only : calculate_density_second_derivs_linear +use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear +use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright +use MOM_EOS_Wright, only : calculate_density_derivs_wright +use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright +use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright +use MOM_EOS_Wright, only : calculate_density_second_derivs_wright +use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco +use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco +use MOM_EOS_UNESCO, only : calculate_compress_unesco +use MOM_EOS_NEMO, only : calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_compress_nemo +use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 +use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_compress_teos10 +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero +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_unit_scaling, only : unit_scale_type + +use MOM_EOS, only : EOS_LINEAR, EOS_UNESCO, EOS_WRIGHT, EOS_TEOS10, EOS_NEMO + +implicit none ; private + +#include + +public int_density_dz +public int_density_dz_generic_pcm +public int_density_dz_generic_plm +public int_density_dz_generic_ppm +public int_specific_vol_dp +public int_spec_vol_dp_generic_pcm +public int_spec_vol_dp_generic_plm +public find_depth_of_pressure_in_cell + +contains + +!> 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 Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + 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] + 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] + 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] + 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. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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] + 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] + 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] + 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] + 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] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! 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. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_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) + endif + +end subroutine int_specific_vol_dp + + +!> This subroutine calculates analytical and nearly-analytical integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + 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(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) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + 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. + 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(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(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(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(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 minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + call analytic_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) + endif + +end subroutine int_density_dz + + +!> 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_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. + 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) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + 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. + 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(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(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(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(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 minuscule 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 :: 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 ! 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 :: 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 + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + 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 = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + enddo + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + 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 + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,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. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif + + ! Use Boole'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))) + enddo + ! Use Boole'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 + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,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. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif + + ! Use Boole'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))) + enddo + ! Use Boole'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 +end subroutine int_density_dz_generic_pcm + + +!> 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, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + 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(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. + 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 minuscule thickness change [Z ~> m] + 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(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(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(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] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are linear in the +! vertical. The top and bottom values within each layer are provided and +! a linear interpolation is used to compute intermediate values. + + ! Local variables + 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] + 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] + 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(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 ! Non-dimensional weights of the top and bottom [nondim] + real :: massWeightToggle ! A non-dimensional 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 :: pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + 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(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(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 + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif + + do i=isq,ieq+1 + ! Use Boole'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 + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo + enddo ! end loops on j + + ! 2. Compute horizontal integrals in the x direction + 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 + ! 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(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_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(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(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(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 + ! 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(i,j) + w_right*z_t(i+1,j)) + + ! 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 + + 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) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif + + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole'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 Boole'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 + + ! 3. Compute horizontal integrals in the y direction + 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 + ! 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(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_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(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(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(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 + ! 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(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 + + ! 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 + + if (rho_scale /= 1.0) then + call calculate_density(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(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=HI%isc,HI%iec + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole'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 Boole'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 + +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) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [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 + 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 :: 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) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + 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 + if (present(z_tol)) Pa_tol = GxRho * z_tol + + 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 ) + + if (PaPa_right) then + 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) + + enddo + +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, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [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 [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 + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures 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 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + 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(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole'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 + frac_dp_at_pos = G_e * dz * rho_ave +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, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + 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) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_b !< Potential temperature at the cell bottom [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) :: S_t !< Salinity at the cell top [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + 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(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. + 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(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(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(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] + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are linear in the +! vertical. The top and bottom values within each layer are provided and +! a linear interpolation is used to compute intermediate values. + +!### Please note that this subroutine has not been verified to work properly! + + ! Local variables + 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 ! 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 + real :: s0, s1, s2 ! parabola coefficients for S [ppt] + real :: t0, t1, t2 ! parabola coefficients for T [degC] + 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 + real, dimension(4) :: x, y + real, dimension(9) :: S_node, T_node, p_node, r_node + + + call MOM_error(FATAL, & + "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + 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 = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + + ! Coefficients of the parabola for S + s0 = S_t(i,j) + s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) + s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) + + ! Coefficients of the parabola for T + t0 = T_t(i,j) + t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) + t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) + + do n=1,5 + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + + ! Parabolic reconstruction for T and S + xi = 0.25 * ( n - 1 ) + S5(n) = s0 + s1 * xi + s2 * xi**2 + T5(n) = t0 + t1 * xi + t2 * xi**2 + enddo + + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + + dpa(i,j) = G_e*dz*rho_anom + + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + 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 ! end loops on j and i + + ! 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,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)) + + ! 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. + T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) + T_mid = w_left*T(i,j) + w_right*T(i+1,j) + T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) + + S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) + S_mid = w_left*S(i,j) + w_right*S(i+1,j) + S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) + + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + + ! Pressure + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Coefficients of the parabola for S + s0 = S_top + s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot + s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) + + ! Coefficients of the parabola for T + t0 = T_top + t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot + t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) + + do n=1,5 + ! Parabolic reconstruction for T and S + xi = 0.25 * ( n - 1 ) + S5(n) = s0 + s1 * xi + s2 * xi**2 + T5(n) = t0 + t1 * xi + t2 * xi**2 + enddo + +stop + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif + + ! Use Boole'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)) ) + enddo + 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 + + ! The following coordinates define the quadrilateral on which the integral + ! is computed + x(1) = 1.0 + x(2) = 0.0 + x(3) = 0.0 + x(4) = 1.0 + y(1) = z_t(i+1,j) + y(2) = z_t(i,j) + y(3) = z_b(i,j) + y(4) = z_b(i+1,j) + + T_node = 0.0 + p_node = 0.0 + + ! Nodal values for S + + ! Parabolic reconstruction on the left + s0 = S_t(i,j) + s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) + s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) + S_node(2) = s0 + S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 + S_node(3) = s0 + s1 + s2 + + ! Parabolic reconstruction on the left + s0 = S_t(i+1,j) + s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) + s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) + S_node(1) = s0 + S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 + S_node(4) = s0 + s1 + s2 + + S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) + S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) + 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=rho_ref_mks, scale=rho_scale ) + else + 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 + + call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) + + intx_dpa(i,j) = intx_dpa(i,j) * G_e + + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then + 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,j) = 0.0 + + enddo ; enddo + endif + +end subroutine int_density_dz_generic_ppm + + +!> Compute the integral of the quadratic function +subroutine compute_integral_quadratic( x, y, f, integral ) + real, dimension(4), intent(in) :: x !< The x-position of the corners + real, dimension(4), intent(in) :: y !< The y-position of the corners + real, dimension(9), intent(in) :: f !< The function at the quadrature points + real, intent(out) :: integral !< The returned integral + + ! Local variables + integer :: i, k + real, dimension(9) :: weight, xi, eta ! integration points + real :: f_k + real :: dxdxi, dxdeta + real :: dydxi, dydeta + real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta + real, dimension(9) :: phi, dphidxi, dphideta + real :: jacobian_k + real :: t + + ! Quadrature rule (4 points) + !weight(:) = 1.0 + !xi(1) = - sqrt(3.0) / 3.0 + !xi(2) = sqrt(3.0) / 3.0 + !xi(3) = sqrt(3.0) / 3.0 + !xi(4) = - sqrt(3.0) / 3.0 + !eta(1) = - sqrt(3.0) / 3.0 + !eta(2) = - sqrt(3.0) / 3.0 + !eta(3) = sqrt(3.0) / 3.0 + !eta(4) = sqrt(3.0) / 3.0 + + ! Quadrature rule (9 points) + t = sqrt(3.0/5.0) + weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t + weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t + weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t + weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 + weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 + weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 + weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t + weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t + weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t + + integral = 0.0 + + ! Integration loop + do k = 1,9 + + ! Evaluate shape functions and gradients for isomorphism + call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & + dphiisodxi, dphiisodeta ) + + ! Determine gradient of global coordinate at integration point + dxdxi = 0.0 + dxdeta = 0.0 + dydxi = 0.0 + dydeta = 0.0 + + do i = 1,4 + dxdxi = dxdxi + x(i) * dphiisodxi(i) + dxdeta = dxdeta + x(i) * dphiisodeta(i) + dydxi = dydxi + y(i) * dphiisodxi(i) + dydeta = dydeta + y(i) * dphiisodeta(i) + enddo + + ! Evaluate Jacobian at integration point + jacobian_k = dxdxi*dydeta - dydxi*dxdeta + + ! Evaluate shape functions for interpolation + call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) + + ! Evaluate function at integration point + f_k = 0.0 + do i = 1,9 + f_k = f_k + f(i) * phi(i) + enddo + + integral = integral + weight(k) * f_k * jacobian_k + + enddo ! end integration loop + +end subroutine compute_integral_quadratic + + +!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) +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(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(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: + ! + ! (-1,1) 2 o------------o 1 (1,1) + ! | | + ! | | + ! | | + ! | | + ! (-1,-1) 3 o------------o 4 (1,-1) + ! + + phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) + phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) + phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) + phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) + + dphidxi(1) = 0.25 * ( 1 + eta ) + dphidxi(2) = - 0.25 * ( 1 + eta ) + dphidxi(3) = - 0.25 * ( 1 - eta ) + dphidxi(4) = 0.25 * ( 1 - eta ) + + dphideta(1) = 0.25 * ( 1 + xi ) + dphideta(2) = 0.25 * ( 1 - xi ) + dphideta(3) = - 0.25 * ( 1 - xi ) + dphideta(4) = - 0.25 * ( 1 + xi ) + +end subroutine evaluate_shape_bilinear + + +!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) +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(inout) :: phi !< The weights of the 9 bilinear quadrature points + !! at this point + 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(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: + ! + ! 5 (0,1) + ! (-1,1) 2 o------o------o 1 (1,1) + ! | | + ! | 9 (0,0) | + ! (-1,0) 6 o o o 8 (1,0) + ! | | + ! | | + ! (-1,-1) 3 o------o------o 4 (1,-1) + ! 7 (0,-1) + ! + + phi(:) = 0.0 + dphidxi(:) = 0.0 + dphideta(:) = 0.0 + + phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) + phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) + phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) + phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) + phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) + phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) + phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) + phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) + phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) + + !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) + !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) + !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) + !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) + !dphidxi(5) = - xi * eta * ( 1 + eta ) + !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) + !dphidxi(7) = xi * eta * ( 1 - eta ) + !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) + !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) + + !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) + !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) + !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) + !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) + !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) + !dphideta(6) = xi * ( 1 - xi ) * eta + !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) + !dphideta(8) = - xi * ( 1 + xi ) * eta + !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta + +end subroutine evaluate_shape_quadratic + + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< 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 [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] + 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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] + 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] + 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] + 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] + 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] + real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with + !! 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. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole'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. + + ! 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 [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 + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) + enddo + + 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 Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + 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) - RL2_T2_to_Pa * 0.25*dp + enddo + 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 Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + 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) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) + enddo + 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 Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_pcm + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole'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, US, dza, & + intp_dza, intx_dza, inty_dza, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_t !< Potential temperature at the top of the layer [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + 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] + 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 [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] + 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 [R L2 T-2 ~> Pa] or [Pa] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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] + 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] + 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] + 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] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole'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) ! 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 [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 [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 + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + 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) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = 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 + 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 Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = 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 + + 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 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = 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 + + 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 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + +end module MOM_density_integrals + +!> \namespace mom_density_integrals +!! diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index fc775d938f..b8cf161148 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -9,7 +9,7 @@ module MOM_interface_heights 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 +use MOM_density_integrals, only : int_specific_vol_dp implicit none ; private @@ -109,7 +109,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) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=jsv,jev @@ -214,7 +214,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) + G%HI, tv%eqn_of_state, US, 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 58bc196744..7a33dc7d77 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -7,7 +7,7 @@ module MOM_isopycnal_slopes 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 use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index f26e7fc815..d51173c16b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -6,6 +6,7 @@ module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : reproducing_sum +use MOM_density_integrals, only : int_density_dz use MOM_diag_mediator, only : post_data, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field use MOM_diag_mediator, only : register_static_field, diag_register_area_ids @@ -15,7 +16,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, calculate_density_derivs, int_density_dz, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, 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 @@ -863,7 +864,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, tv%eqn_of_state, dpress) + G%HI, tv%eqn_of_state, US, 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/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 44d34ce475..b3cfcab83f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -42,10 +42,8 @@ module MOM_EOS public calculate_density_second_derivs 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 -public int_spec_vol_dp_generic_plm !, int_spec_vol_dz_generic_ppm -public int_density_dz_generic, int_spec_vol_dp_generic +public analytic_int_density_dz, analytic_int_specific_vol_dp +public EOS_quadrature public find_depth_of_pressure_in_cell public calculate_TFreeze public convert_temp_salt_for_TEOS10 @@ -1141,7 +1139,7 @@ end function EOS_domain !! non-Boussinesq model. There are essentially no free assumptions, apart from the !! use of Bode's rule to do the horizontal integrals, and from a truncation in the !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & +subroutine analytic_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) type(hor_index_type), intent(in) :: HI !< The horizontal index structure @@ -1189,9 +1187,7 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") if (EOS%EOS_quadrature) then - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + call MOM_error(FATAL, "EOS_quadrature is set!") 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%kg_m3_to_R*EOS%Rho_T0_S0, & @@ -1203,17 +1199,15 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & 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) + call MOM_error(FATAL, "Set EOS_QUADRATURE!") end select ; endif -end subroutine int_specific_vol_dp +end subroutine analytic_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, HI, EOS, dpa, & +subroutine analytic_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) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -1262,8 +1256,7 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & "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, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + call MOM_error(FATAL, "EOS_quadrature is set!") else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R @@ -1289,11 +1282,10 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & dz_neglect, useMassWghtInterp) endif case default - 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) + call MOM_error(FATAL, "Use EOS_QUADRATURE!") end select ; endif -end subroutine int_density_dz +end subroutine analytic_int_density_dz !> Returns true if the equation of state is compressible (i.e. has pressure dependence) logical function query_compressible(EOS) @@ -1487,526 +1479,6 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> This subroutine calculates (by numerical quadrature) integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - 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(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) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - 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. - 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(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(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(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(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(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 - !! interpolate T/S for top and bottom integrals. - ! 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 ! 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 :: 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 - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - 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 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - enddo - if (rho_scale /= 1.0) then - 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=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)) - 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,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 - - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,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. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - 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=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))) - 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 - - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,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. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - 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=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))) - 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 -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, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) - 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(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - 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(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. - 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(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(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(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(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(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] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - - ! Local variables - 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] - 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] - 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(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] - 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 :: pos - - 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 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif - - do n = 1, 5 - wt_t(n) = 0.25 * real(5-n) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 - 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(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(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 - 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=rho_ref_mks) - endif - - 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 - if (present(intz_dpa)) then - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & - (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) - endif - enddo - enddo ! end loops on j - - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - 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 - ! 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(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_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(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(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(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 - ! 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(i,j) + w_right*z_t(i+1,j)) - - ! 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 - - 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) - else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) - endif - - 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)) - enddo - enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq - do i=HI%isc,HI%iec - ! 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(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_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(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(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(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 - ! 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(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 - - ! 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 - - 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:), & - 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*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=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. - 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 - enddo ; endif - -end subroutine int_density_dz_generic_plm -! ========================================================================== -! Above is the routine where only the S and T profiles are modified -! The real topography is still used -! ========================================================================== - !> 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) @@ -2130,274 +1602,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 frac_dp_at_pos = G_e * dz * rho_ave 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, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - - 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(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [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) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - 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(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. - 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(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(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(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(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] - -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - -!### Please note that this subroutine has not been verified to work properly! - - ! Local variables - 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 ! 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 - real :: s0, s1, s2 ! parabola coefficients for S [ppt] - real :: t0, t1, t2 ! parabola coefficients for T [degC] - 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 - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - 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 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - - do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - if (rho_scale /= 1.0) then - 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=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)) - - 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,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 ! end loops on j and i - - ! ================================================== - ! 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,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)) - - ! 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. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) - - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - - do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - -stop - if (rho_scale /= 1.0) then - 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=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)) ) - enddo - 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 - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - 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=rho_ref_mks, scale=rho_scale ) - else - 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 - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) - - intx_dpa(i,j) = intx_dpa(i,j) * G_e - - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then - 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,j) = 0.0 - - enddo ; enddo - endif - -end subroutine int_density_dz_generic_ppm - - - ! ============================================================================= !> Compute the integral of the quadratic function subroutine compute_integral_quadratic( x, y, f, integral ) @@ -2584,475 +1788,6 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) end subroutine evaluate_shape_quadratic ! ============================================================================== -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - 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] - 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 [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] - 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 [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] - 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] - 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] - 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] - real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! 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. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - ! 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 [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 - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) - ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - 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 - do_massWeight = .true. - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=jsh,jeh ; do i=ish,ieh - dp = p_b(i,j) - p_t(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) - enddo - - 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)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = 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) - RL2_T2_to_Pa * 0.25*dp - enddo - 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)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = 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) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) - enddo - 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)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in y. - inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & - dP_neglect, bathyP, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperature at the top of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - 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] - 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 [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] - 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 [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 [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] - 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] - 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] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - real :: 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 [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 [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 - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - - 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) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1; do i=Isq,Ieq+1 - dp = p_b(i,j) - p_t(i,j) - do n=1,5 ! T, S and p are linearly interpolated in the vertical. - p5(n) = 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 - 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)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = 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 - - 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 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = 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 - - 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 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic_plm - !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) integer, intent(in) :: kd !< The number of layers to work on @@ -3086,6 +1821,14 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 +!> Return value of EOS_quadrature +logical function EOS_quadrature(EOS) + type(EOS_type), pointer :: EOS !< Equation of state structure + + EOS_quadrature = EOS%EOS_quadrature + +end function EOS_quadrature + !> Extractor routine for the EOS type if the members need to be accessed outside this module subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 6ca98da171..bd2b144e96 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -4,6 +4,7 @@ module MOM_state_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_density_integrals, only : int_specific_vol_dp use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP @@ -41,7 +42,7 @@ module MOM_state_initialization use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_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 MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity use user_initialization, only : user_init_temperature_salinity use user_initialization, only : user_set_OBC_data @@ -970,7 +971,7 @@ 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) + tv%eqn_of_state, US, 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, EOSdom) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 6011ebb9f8..1a4c5bd011 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -7,6 +7,7 @@ module MOM_tracer_initialization_from_Z use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_density_integrals, only : int_specific_vol_dp use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -24,7 +25,6 @@ module MOM_tracer_initialization_from_Z use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type -use MOM_EOS, only : int_specific_vol_dp use MOM_ALE, only : ALE_remap_scalar implicit none ; private From 2e1d82369c8ae015e26954ffe3decc171ffe22fe Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 17:36:30 +0000 Subject: [PATCH 125/256] Renamed ppoly_E to edge_values for a bit of clarity - ppoly_E meant something to someone a while ago but we felt it would be better to clean up the ALE APIs. This is a pre-cursor to switching to a more precise description of reconstructions. --- src/ALE/MOM_remapping.F90 | 12 +++--- src/ALE/P1M_functions.F90 | 40 +++++++++--------- src/ALE/P3M_functions.F90 | 54 ++++++++++++------------ src/ALE/PCM_functions.F90 | 6 +-- src/ALE/PLM_functions.F90 | 56 ++++++++++++------------- src/ALE/PPM_functions.F90 | 48 ++++++++++----------- src/ALE/PQM_functions.F90 | 88 +++++++++++++++++++-------------------- src/ALE/regrid_interp.F90 | 14 +++---- 8 files changed, 159 insertions(+), 159 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 65cf5b9d55..71ba83f3ba 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1027,11 +1027,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly !> Measure totals and bounds on source grid -subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) +subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,2), intent(in) :: ppoly_E !< Cell edge values on source grid + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid real, intent(out) :: h0tot !< Sum of cell widths real, intent(out) :: h0err !< Magnitude of round-off error in h0tot real, intent(out) :: u0tot !< Sum of cell widths times values @@ -1047,15 +1047,15 @@ subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err h0err = 0. u0tot = h0(1) * u0(1) u0err = 0. - u0min = min( ppoly_E(1,1), ppoly_E(1,2) ) - u0max = max( ppoly_E(1,1), ppoly_E(1,2) ) + u0min = min( edge_values(1,1), edge_values(1,2) ) + u0max = max( edge_values(1,1), edge_values(1,2) ) do k = 2, n0 h0tot = h0tot + h0(k) h0err = h0err + eps * max(h0tot, h0(k)) u0tot = u0tot + h0(k) * u0(k) u0err = u0err + eps * max(abs(u0tot), abs(h0(k) * u0(k))) - u0min = min( u0min, ppoly_E(k,1), ppoly_E(k,2) ) - u0max = max( u0max, ppoly_E(k,1), ppoly_E(k,2) ) + u0min = min( u0min, edge_values(k,1), edge_values(k,2) ) + u0max = max( u0max, edge_values(k,1), edge_values(k,2) ) enddo end subroutine measure_input_bounds diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index f2c85d9872..d99c611229 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -24,11 +24,11 @@ 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, answers_2018 ) +subroutine P1M_interpolation( N, h, u, edge_values, 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 average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] @@ -39,17 +39,17 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2 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, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! Loop on interior cells to build interpolants do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) ppoly_coef(k,1) = u0_l ppoly_coef(k,2) = u0_r - u0_l @@ -65,12 +65,12 @@ end subroutine P1M_interpolation !! !! 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_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) ! Arguments 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables @@ -99,20 +99,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then - slope = 2.0 * ( ppoly_E(2,1) - u0 ) + if ( (u1 - u0) * (edge_values(2,1) - u0_r) < 0.0 ) then + slope = 2.0 * ( edge_values(2,1) - u0 ) endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed if ( h0 /= 0.0 ) then - ppoly_E(1,1) = u0 - 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope else - ppoly_E(1,1) = u0 + edge_values(1,1) = u0 endif - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -127,18 +127,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then - slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) + if ( (u1 - u0) * (u0_l - edge_values(N-1,2)) < 0.0 ) then + slope = 2.0 * ( u1 - edge_values(N-1,2) ) endif if ( h1 /= 0.0 ) then - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope else - ppoly_E(N,2) = u1 + edge_values(N,2) = u1 endif - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 434668894b..e3a9f75a3c 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,11 +25,11 @@ 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, answers_2018 ) +subroutine P3M_interpolation( N, h, u, edge_values, 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] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -41,7 +41,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, ! 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, answers_2018 ) + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) end subroutine P3M_interpolation @@ -58,11 +58,11 @@ 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, answers_2018 ) +subroutine P3M_limiter( N, h, u, edge_values, 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] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for @@ -86,10 +86,10 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer 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, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! 2. Systematically average discontinuous edge values - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! 3. Loop on cells and do the following @@ -99,8 +99,8 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer do k = 1,N ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) u1_r = ppoly_S(k,2) @@ -151,7 +151,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic monotonic = is_cubic_monotonic( ppoly_coef, k ) @@ -168,7 +168,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) enddo ! loop on cells @@ -188,12 +188,12 @@ end subroutine P3M_limiter !! computing the parabola based on the cell average and the right edge value !! and slope. The resulting cubic is not necessarily monotonic and the slopes !! are subsequently modified to yield a monotonic cubic. -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & +subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) 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] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -235,7 +235,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -253,13 +253,13 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) if ( .not.monotonic ) then @@ -268,7 +268,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) endif @@ -295,7 +295,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -313,12 +313,12 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) if ( .not.monotonic ) then @@ -327,7 +327,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) endif @@ -340,10 +340,10 @@ end subroutine P3M_boundary_extrapolation !! !! NOTE: edge values and slopes MUST have been properly calculated prior to !! calling this routine. -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) +subroutine build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: edge_values !< Edge value of polynomial in arbitrary units [A] real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] @@ -355,8 +355,8 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) h_c = h(k) - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) * h_c u1_r = ppoly_S(k,2) * h_c diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 135f53a8a1..6608e85eda 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -15,10 +15,10 @@ module PCM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) +subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: u !< cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, !! with the same units as u. @@ -32,7 +32,7 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) ! The edge values are equal to the cell average do k = 1,N - ppoly_E(k,:) = u(k) + edge_values(k,:) = u(k) enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index ed82ad1e0b..e6bcbef331 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -15,11 +15,11 @@ module PLM_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 PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) 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, + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -106,22 +106,22 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! endif slp(k) = slope - ppoly_E(k,1) = u_c - 0.5 * slope - ppoly_E(k,2) = u_c + 0.5 * slope + edge_values(k,1) = u_c - 0.5 * slope + edge_values(k,2) = u_c + 0.5 * slope enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled in a later routine. slp(1) = 0. - ppoly_E(1,2) = u(1) + edge_values(1,2) = u(1) slp(N) = 0. - ppoly_E(N,1) = u(N) + edge_values(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = ppoly_E(k-1,2) ! Right edge from cell k-1 - e_l = ppoly_E(k+1,1) ! Left edge from cell k + e_r = edge_values(k-1,2) ! Right edge from cell k-1 + e_l = edge_values(k+1,1) ! Left edge from cell k mslp(k) = abs(slp(k)) u_min = min(e_r, u_c) u_max = max(e_r, u_c) @@ -149,8 +149,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! enddo ! end loop on interior cells ! Store and return edge values and polynomial coefficients. - ppoly_E(1,1) = u(1) - ppoly_E(1,2) = u(1) + edge_values(1,1) = u(1) + edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 @@ -172,8 +172,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) stop 'Right edge out of bounds' endif - ppoly_E(k,1) = u_l - ppoly_E(k,2) = u_r + edge_values(k,1) = u_l + edge_values(k,2) = u_r ppoly_coef(k,1) = u_l ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be @@ -184,8 +184,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo - ppoly_E(N,1) = u(N) - ppoly_E(N,2) = u(N) + edge_values(N,1) = u(N) + edge_values(N,2) = u(N) ppoly_coef(N,1) = u(N) ppoly_coef(N,2) = 0. @@ -202,11 +202,11 @@ end subroutine PLM_reconstruction !! 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 PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) 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, + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -232,17 +232,17 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) u1 = u(2) ! The h2 scheme is used to compute the right edge value - ppoly_E(1,2) = (u0*h1 + u1*h0) / (h0 + h1) + edge_values(1,2) = (u0*h1 + u1*h0) / (h0 + h1) ! The standard PLM slope is computed as a first estimate for the ! reconstruction within the cell - slope = 2.0 * ( ppoly_E(1,2) - u0 ) + slope = 2.0 * ( edge_values(1,2) - u0 ) - ppoly_E(1,1) = u0 - 0.5 * slope - ppoly_E(1,2) = u0 + 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope + edge_values(1,2) = u0 + 0.5 * slope - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -254,17 +254,17 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) u1 = u(N) ! The h2 scheme is used to compute the right edge value - ppoly_E(N,1) = (u0*h1 + u1*h0) / (h0 + h1) + edge_values(N,1) = (u0*h1 + u1*h0) / (h0 + h1) ! The standard PLM slope is computed as a first estimate for the ! reconstruction within the cell - slope = 2.0 * ( u1 - ppoly_E(N,1) ) + slope = 2.0 * ( u1 - edge_values(N,1) ) - ppoly_E(N,1) = u1 - 0.5 * slope - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u1 - 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 6d50703975..bbf93b4a81 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,11 +25,11 @@ 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, answers_2018) +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, 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 averages [A] - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values [A] + real, dimension(N,2), intent(inout) :: edge_values !< 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. @@ -39,13 +39,13 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_ real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) ! Loop over all cells do k = 1,N - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) ! Store polynomial coefficients ppoly_coef(k,1) = edge_l @@ -59,11 +59,11 @@ 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, answers_2018 ) +subroutine PPM_limiter_standard( N, h, u, edge_values, 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -74,10 +74,10 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Make discontinuous edge values monotonic - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the standard ! PPM limiter (Colella & Woodward, JCP 84) @@ -88,8 +88,8 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) u_c = u(k) u_r = u(k+1) - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then ! Flatten extremum @@ -116,21 +116,21 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) edge_r = u_c endif - ppoly_E(k,1) = edge_l - ppoly_E(k,2) = edge_r + edge_values(k,1) = edge_l + edge_values(k,2) = edge_r enddo ! end loop on interior cells ! PCM within boundary cells - ppoly_E(1,:) = u(1) - ppoly_E(N,:) = u(N) + edge_values(1,:) = u(1) + edge_values(N,:) = u(N) end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) +subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,7 +148,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! N: number of cells in grid ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials +! edge_values : edge values of piecewise polynomials ! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells @@ -159,7 +159,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -199,7 +199,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -218,8 +218,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -252,7 +252,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -271,8 +271,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index a2adeb0c13..630ecb34fc 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,12 +17,12 @@ module PQM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -36,16 +36,16 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) ! Loop on cells to construct the cubic within each cell do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) h_c = h(k) @@ -72,12 +72,12 @@ end subroutine PQM_reconstruction !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) +subroutine PQM_limiter( N, h, u, edge_values, 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] 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. @@ -102,10 +102,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! Make discontinuous edge values monotonic (thru averaging) - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 @@ -116,10 +116,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) inflexion_r = 0 ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) ! Get cell widths and cell averages (boundary cells are assumed to ! be local extrema for the sake of slopes) @@ -320,19 +320,19 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction - ppoly_E(k,1) = u0_l - ppoly_E(k,2) = u0_r - ppoly_S(k,1) = u1_l - ppoly_S(k,2) = u1_r + edge_values(k,1) = u0_l + edge_values(k,2) = u0_r + edge_slopes(k,1) = u1_l + edge_slopes(k,2) = u1_r enddo ! end loop on interior cells ! Constant reconstruction within boundary cells - ppoly_E(1,:) = u(1) - ppoly_S(1,:) = 0.0 + edge_values(1,:) = u(1) + edge_slopes(1,:) = 0.0 - ppoly_E(N,:) = u(N) - ppoly_S(N,:) = 0.0 + edge_values(N,:) = u(N) + edge_slopes(N,:) = 0.0 end subroutine PQM_limiter @@ -351,11 +351,11 @@ end subroutine PQM_limiter !! !! 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 PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 @@ -389,7 +389,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -408,8 +408,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -447,7 +447,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -466,8 +466,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r @@ -498,12 +498,12 @@ end subroutine PQM_boundary_extrapolation !! !! 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 PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect ) 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) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -656,10 +656,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r - ppoly_S(i0,1) = u1_l - ppoly_S(i0,2) = u1_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + edge_slopes(i0,1) = u1_l + edge_slopes(i0,2) = u1_r a = u0_l b = h0 * u1_l @@ -809,10 +809,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r - ppoly_S(i1,1) = u1_l - ppoly_S(i1,2) = u1_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + edge_slopes(i1,1) = u1_l + edge_slopes(i1,2) = u1_r a = u0_l b = h1 * u1_l diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 5a1d151487..1ab225474c 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -349,13 +349,13 @@ end subroutine build_and_interpolate_grid !! !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. -function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & +function get_polynomial_coordinate( N, h, x_g, edge_values, 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 [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,2), intent(in) :: edge_values !< 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 @@ -383,7 +383,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value <= ppoly_E(1,1) ) then + if ( target_value <= edge_values(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further endif @@ -391,7 +391,7 @@ 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 >= edge_values(k-1,2) ) .AND. ( target_value <= edge_values(k,1) ) ) then x_tgt = x_g(k) return ! return because there is no need to look further endif @@ -400,7 +400,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value >= ppoly_E(N,2) ) then + if ( target_value >= edge_values(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further endif @@ -411,7 +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 > edge_values(k,1) ) .AND. ( target_value < edge_values(k,2) ) ) then k_found = k exit endif @@ -425,7 +425,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( k_found == -1 ) then 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) + target_value, edge_values(1,1), edge_values(N,2) call MOM_error( FATAL, mesg ) endif From 05dbf8640242005f5d641259acb3c1338368f140 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:43:36 +0000 Subject: [PATCH 126/256] Cleaned up unused use statements --- src/core/MOM_density_integrals.F90 | 51 +++++++----------------------- 1 file changed, 12 insertions(+), 39 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 4cd9c8fc48..0ac4906158 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -3,46 +3,19 @@ module MOM_density_integrals ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_EOS, only : EOS_type -use MOM_EOS, only : EOS_quadrature -use MOM_EOS, only : analytic_int_density_dz -use MOM_EOS, only : analytic_int_specific_vol_dp -use MOM_EOS, only : calculate_density -use MOM_EOS, only : calculate_spec_vol -use MOM_EOS, only : calculate_specific_vol_derivs -use MOM_EOS, only : calculate_density_second_derivs - -use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear -use MOM_EOS_linear, only : calculate_density_derivs_linear -use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear -use MOM_EOS_linear, only : calculate_density_second_derivs_linear -use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear -use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright -use MOM_EOS_Wright, only : calculate_density_derivs_wright -use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright -use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright -use MOM_EOS_Wright, only : calculate_density_second_derivs_wright -use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco -use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco -use MOM_EOS_UNESCO, only : calculate_compress_unesco -use MOM_EOS_NEMO, only : calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_compress_nemo -use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 -use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_compress_teos10 -use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero -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_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : calculate_density_second_derivs +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_unit_scaling, only : unit_scale_type - -use MOM_EOS, only : EOS_LINEAR, EOS_UNESCO, EOS_WRIGHT, EOS_TEOS10, EOS_NEMO +use MOM_unit_scaling, only : unit_scale_type implicit none ; private From 7171c1aa09a27c056aa63f032c3b888cd1144201 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:44:43 +0000 Subject: [PATCH 127/256] Tidied up logic for EOS_QUADRATURE - Undid nesting of if / select statemnent - Changed FATAL messages --- src/equation_of_state/MOM_EOS.F90 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index b3cfcab83f..9622ab4f38 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1186,9 +1186,11 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call MOM_error(FATAL, "EOS_quadrature is set!") - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + 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%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, & @@ -1199,8 +1201,8 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & 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 MOM_error(FATAL, "Set EOS_QUADRATURE!") - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select end subroutine analytic_int_specific_vol_dp @@ -1255,9 +1257,11 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call MOM_error(FATAL, "EOS_quadrature is set!") - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then @@ -1282,8 +1286,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dz_neglect, useMassWghtInterp) endif case default - call MOM_error(FATAL, "Use EOS_QUADRATURE!") - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select end subroutine analytic_int_density_dz From 6a0b23d1a2751cebd748e7af98bb7dc718f4e5b1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:50:39 +0000 Subject: [PATCH 128/256] Removed find_depth_of_pressure_in_cell() from MOM_EOS - Function had been moved to density_integrals already but not deleted - Also ordered public statements in MOM_EOS to help find things. --- src/equation_of_state/MOM_EOS.F90 | 333 +----------------- .../MOM_state_initialization.F90 | 6 +- 2 files changed, 20 insertions(+), 319 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9622ab4f38..583bb8fcbc 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -37,18 +37,27 @@ module MOM_EOS #include -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, EOS_domain -public EOS_use_linear, calculate_spec_vol -public analytic_int_density_dz, analytic_int_specific_vol_dp +public EOS_allocate +public EOS_domain +public EOS_end +public EOS_init +public EOS_manual_init public EOS_quadrature -public find_depth_of_pressure_in_cell +public EOS_use_linear +public analytic_int_density_dz +public analytic_int_specific_vol_dp +public calculate_compress +public calculate_density +public calculate_density_derivs +public calculate_density_second_derivs +public calculate_spec_vol +public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public gsw_sp_from_sr, gsw_pt_from_ct public extract_member_EOS +public gsw_sp_from_sr +public gsw_pt_from_ct +public query_compressible ! 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 @@ -1483,314 +1492,6 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> 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) - 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 [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 [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 :: 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) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - 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*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) - 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 ) - - if (PaPa_right) then - 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) - - enddo - -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, 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 [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 [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 - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: dz ! Distance from the layer top [Z ~> m] - 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 - ! Evalute density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - 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_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 - 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 - frac_dp_at_pos = G_e * dz * rho_ave -end function frac_dp_at_pos - -! ============================================================================= -!> Compute the integral of the quadratic function -subroutine compute_integral_quadratic( x, y, f, integral ) - real, dimension(4), intent(in) :: x !< The x-position of the corners - real, dimension(4), intent(in) :: y !< The y-position of the corners - real, dimension(9), intent(in) :: f !< The function at the quadrature points - real, intent(out) :: integral !< The returned integral - - ! Local variables - integer :: i, k - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo - - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta - - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) - - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo - - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -end subroutine compute_integral_quadratic - - -! ============================================================================= -!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) -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(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(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: - ! - ! (-1,1) 2 o------------o 1 (1,1) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -! ============================================================================= -!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) -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(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - 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(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: - ! - ! 5 (0,1) - ! (-1,1) 2 o------o------o 1 (1,1) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - phi(:) = 0.0 - dphidxi(:) = 0.0 - dphideta(:) = 0.0 - - phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) - phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic -! ============================================================================== !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index bd2b144e96..e451966364 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -5,12 +5,12 @@ module MOM_state_initialization use MOM_debugging, only : hchksum, qchksum, uvchksum use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : find_depth_of_pressure_in_cell use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_EOS, only : find_depth_of_pressure_in_cell use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type @@ -1219,7 +1219,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, 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, & - P_b, z_out, z_tol=z_tol) + 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 exit @@ -2471,7 +2471,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, P_b, 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 From 5b59cdcef25d58d84ae78814c8fb6616b681f3fe Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 22:16:02 +0000 Subject: [PATCH 129/256] Reordered function in MOM_density_integrals - Order was frustratingly illogical --- src/core/MOM_density_integrals.F90 | 380 ++++++++++++++--------------- 1 file changed, 190 insertions(+), 190 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 0ac4906158..76cee52dbd 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -33,68 +33,9 @@ module MOM_density_integrals contains !> Calls the appropriate subroutine to calculate analytical and nearly-analytical -!! integrals in pressure across layers of geopotential anomalies, which are +!! integrals in z across layers of pressure 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 Boole's rule to do the horizontal integrals, and from a truncation in the -!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - 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] - 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] - 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] - 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. - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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] - 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] - 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] - 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] - 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] - real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with - !! 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. - - if (EOS_quadrature(EOS)) then - call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - else - call analytic_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) - endif - -end subroutine int_specific_vol_dp - - -!> This subroutine calculates analytical and nearly-analytical integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. +!! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays @@ -148,9 +89,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, end subroutine int_density_dz -!> 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. +!> 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_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) @@ -659,132 +599,6 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 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) - real, intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature 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 [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 - 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 :: 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) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - 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 - if (present(z_tol)) Pa_tol = GxRho * z_tol - - 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 ) - - if (PaPa_right) then - 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) - - enddo - -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, intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature 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 [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 [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 - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: dz ! Distance from the layer top [Z ~> m] - real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] - real :: rho_ave ! Average density [R ~> kg m-3] - real, dimension(5) :: T5 ! Temperatures 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 - ! Evaluate density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - 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(T5, S5, p5, rho5, EOS) - rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref - - ! Use Boole'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 - frac_dp_at_pos = G_e * dz * rho_ave -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, & @@ -1227,6 +1041,66 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) end subroutine evaluate_shape_quadratic +!> 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 Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + 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] + 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] + 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] + 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. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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] + 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] + 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] + 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] + 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] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! 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. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_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) + endif + +end subroutine int_specific_vol_dp + + !> This subroutine calculates integrals of specific volume anomalies in !! pressure across layers, which are required for calculating the finite-volume !! form pressure accelerations in a non-Boussinesq model. There are essentially @@ -1692,6 +1566,132 @@ 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 + +!> 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) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [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 + 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 :: 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) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + 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 + if (present(z_tol)) Pa_tol = GxRho * z_tol + + 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 ) + + if (PaPa_right) then + 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) + + enddo + +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, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [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 [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 + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures 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 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + 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(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole'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 + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + end module MOM_density_integrals !> \namespace mom_density_integrals From d3e17902e12e25635fc7324122c3a85090ce55e7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 13 May 2020 15:23:46 +0000 Subject: [PATCH 130/256] Use SZ macros in declarations - When converting from the two hor_index types to one (HII and HIO became HI) I retained the HI%isd:... declaration statements. We normally use `SZI_(G)` or `SZI_(HI)` so this switches to that style. --- src/core/MOM_density_integrals.F90 | 140 ++++++++++++++--------------- 1 file changed, 70 insertions(+), 70 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 76cee52dbd..486189b7f6 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -39,13 +39,13 @@ module MOM_density_integrals subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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 @@ -57,22 +57,22 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, !! [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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -95,13 +95,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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 @@ -113,22 +113,22 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! [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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -298,17 +298,17 @@ 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, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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. @@ -316,21 +316,21 @@ 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 minuscule thickness change [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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] @@ -605,21 +605,21 @@ 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, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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. @@ -628,17 +628,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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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] @@ -1051,13 +1051,13 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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] @@ -1065,23 +1065,23 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & !! alpha_ref, but this reduces the effects of roundoff. type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly across !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] @@ -1109,13 +1109,13 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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] @@ -1124,23 +1124,23 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d !! answers do change. type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] @@ -1324,17 +1324,17 @@ 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, US, dza, & intp_dza, intx_dza, inty_dza, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the top of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the top the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the bottom the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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] @@ -1343,22 +1343,22 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, !! answers do change. real, intent(in) :: dP_neglect ! Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [L2 T-2 ~> m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & 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), & + real, dimension(SZIB_(HI),SZJ_(HI)), & 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), & + real, dimension(SZI_(HI),SZJB_(HI)), & 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] From 3e1f6b6db2966e00b24021246b4e6db72558d623 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 May 2020 16:12:05 +0000 Subject: [PATCH 131/256] Implemented elemental PLM functions - This adds elemental functions for cellwise operations within the PLM construction procedure which allows the operations to be accessed from outside of the ALE functions on different array shapes but recover bitwise identical results. - The older subroutines now use the functions and some optimizations were obtained in the process. --- src/ALE/MOM_ALE.F90 | 77 +++++---- src/ALE/PLM_functions.F90 | 318 ++++++++++++++++++++------------------ 2 files changed, 217 insertions(+), 178 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 1d9c66001b..7c4453a292 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -52,6 +52,7 @@ module MOM_ALE use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent use regrid_edge_values, only : edge_values_implicit_h4 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation implicit none ; private @@ -110,6 +111,7 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar +public ALE_PLM_edge_values public TS_PLM_edge_values public TS_PPM_edge_values public adjustGridForIntegrity @@ -1026,12 +1028,31 @@ subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells + call ALE_PLM_edge_values( CS, G, GV, h, tv%S, bdry_extrap, S_t, S_b ) + call ALE_PLM_edge_values( CS, G, GV, h, tv%T, bdry_extrap, T_t, T_b ) + +end subroutine TS_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) 3d scalar array. +!! Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) + type(ALE_CS), intent(in) :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Q !< 3d scalar array + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_t !< Scalar at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) - real, dimension(CS%nk,2) :: ppol_E !Edge value of polynomial - real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial + real :: slp(GV%ke) + real :: mslp real :: h_neglect if (.not.CS%answers_2018) then @@ -1042,40 +1063,36 @@ subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap h_neglect = GV%kg_m2_to_H*1.0e-30 endif - ! Determine reconstruction within each column !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) + slp(1) = 0. + do k = 2, GV%ke-1 + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo + slp(GV%ke) = 0. - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) + do k = 2, GV%ke-1 + mslp = PLM_monotonized_slope(Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1), slp(k-1), slp(k), slp(k+1)) + Q_t(i,j,k) = Q(i,j,k) - 0.5 * mslp + Q_b(i,j,k) = Q(i,j,k) + 0.5 * mslp enddo + if (bdry_extrap) then + mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) + Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp + Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp + else + Q_t(i,j,1) = Q(i,j,1) + Q_b(i,j,1) = Q(i,j,1) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + endif enddo ; enddo -end subroutine TS_PLM_edge_values +end subroutine ALE_PLM_edge_values !> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction !! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index e6bcbef331..952202d325 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -5,12 +5,168 @@ module PLM_functions implicit none ; private -public PLM_reconstruction, PLM_boundary_extrapolation +public PLM_boundary_extrapolation +public PLM_extrapolate_slope +public PLM_monotonized_slope +public PLM_reconstruction +public PLM_slope_wa +public PLM_slope_cw real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains +!> Returns a limited PLM slope following White and Adcroft, 2008. [units of u] +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r, u_min, u_max + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r, u_min, u_max, h_cn + + h_cn = h_c + h_neglect + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_cw = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_cw = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_cw) < u_min .or. u_c + 0.5*abs(PLM_slope_cw) > u_max) then + PLM_slope_cw = PLM_slope_cw * ( 1. - epsilon(PLM_slope_cw) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. + +end function PLM_slope_cw + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: s_l !< PLM slope of left cell [units of u] + real, intent(in) :: s_c !< PLM slope of center cell [units of u] + real, intent(in) :: s_r !< PLM slope of right cell [units of u] + ! Local variables + real :: e_r, e_l, edge, almost_two, slp + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Returns a PLM slope using h2 extrapolation from a cell to the left. +!! Use the negative to extrapolate from the a cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + ! Local variables + real :: left_edge, hl, hc + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + + !> Reconstruction by linear polynomials within each cell !! !! It is assumed that the size of the array 'u' is equal to the number of cells @@ -31,147 +187,43 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer :: k ! loop index real :: u_l, u_c, u_r ! left, center and right cell averages real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes real :: slope ! retained PLM slope real :: a, b ! auxiliary variables real :: u_min, u_max, e_l, e_r, edge - real :: almost_one, almost_two + real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) - almost_two = 2. * almost_one ! Loop on interior cells do k = 2,N-1 - - ! Get cell averages - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - - ! Get cell widths - h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, hNeglect ) ! To avoid division by zero - - ! Side differences - sigma_r = u_r - u_c - sigma_l = u_c - u_l - - ! This is the second order slope given by equation 1.7 of - ! Piecewise Parabolic Method, Colella and Woodward (1984), - ! http://dx.doi.org/10.1016/0021-991(84)90143-8. - ! For uniform resolution it simplifies to ( u_r - u_l )/2 . - ! sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & - ! ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & - ! + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) - - ! This is the original estimate of the second order slope from Laurent - ! but multiplied by h_c - sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + hNeglect) ) - - if ( (sigma_l * sigma_r) > 0.0 ) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - slope = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - endif - - ! This block tests to see if roundoff causes edge values to be out of bounds - u_min = min( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then - slope = slope * almost_one - endif - - ! An attempt to avoid inconsistency when the values become unrepresentable. - if (abs(slope) < 1.E-140) slope = 0. - - ! Safety check - this block really should not be needed ... -! if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then -! write(0,*) 'l,c,r=',u_l,u_c,u_r -! write(0,*) 'min,max=',u_min,u_max -! write(0,*) 'slp=',slope -! sigma_l = u_c-0.5*abs(slope) -! sigma_r = u_c+0.5*abs(slope) -! write(0,*) 'lo,hi=',sigma_l,sigma_r -! write(0,*) 'elo,ehi=',sigma_l-u_min,sigma_r-u_max -! stop 'Limiter failed!' -! endif - - slp(k) = slope - edge_values(k,1) = u_c - 0.5 * slope - edge_values(k,2) = u_c + 0.5 * slope - + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells - ! Boundary cells use PCM. Extrapolation is handled in a later routine. + ! Boundary cells use PCM. Extrapolation is handled after monotonization. slp(1) = 0. - edge_values(1,2) = u(1) slp(N) = 0. - edge_values(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = edge_values(k-1,2) ! Right edge from cell k-1 - e_l = edge_values(k+1,1) ! Left edge from cell k - mslp(k) = abs(slp(k)) - u_min = min(e_r, u_c) - u_max = max(e_r, u_c) - edge = u_c - 0.5 * slp(k) - if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then - edge = 0.5 * ( edge + e_r ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif - edge = u_c + 0.5 * slp(k) - if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then - edge = 0.5 * ( edge + e_l ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) enddo ! end loop on interior cells mslp(1) = 0. mslp(N) = 0. - ! Check that the above adjustment worked -! do K = 2, N-1 -! u_r = u(k-1) + 0.5 * sign( mslp(k-1), slp(k-1) ) ! Right edge from cell k-1 -! u_l = u(k) - 0.5 * sign( mslp(k), slp(k) ) ! Left edge from cell k -! if ( (u(k)-u(k-1)) * (u_l-u_r) < 0. ) then -! stop 'Adjustment failed!' -! endif -! enddo ! end loop on interior cells - ! Store and return edge values and polynomial coefficients. edge_values(1,1) = u(1) edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 - slope = sign( mslp(k), slp(k) ) + slope = mslp(k) u_l = u(k) - 0.5 * slope ! Left edge value of cell k u_r = u(k) + 0.5 * slope ! Right edge value of cell k - ! Check that final edge values are bounded - u_min = min( u(k-1), u(k) ) - u_max = max( u(k-1), u(k) ) - if (u_lu_max) then - write(0,*) 'u(k-1)=',u(k-1),'u(k)=',u(k),'slp=',slp(k),'u_l=',u_l - stop 'Left edge out of bounds' - endif - u_min = min( u(k+1), u(k) ) - u_max = max( u(k+1), u(k) ) - if (u_ru_max) then - write(0,*) 'u(k)=',u(k),'u(k+1)=',u(k+1),'slp=',slp(k),'u_r=',u_r - stop 'Right edge out of bounds' - endif - edge_values(k,1) = u_l edge_values(k,2) = u_r ppoly_coef(k,1) = u_l @@ -201,7 +253,6 @@ end subroutine PLM_reconstruction !! !! 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 PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) @@ -213,55 +264,26 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h - ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths real :: slope ! retained PLM slope real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! ----------------------------------------- - ! Left edge value in the left boundary cell - ! ----------------------------------------- - h0 = h(1) + hNeglect - h1 = h(2) + hNeglect - - u0 = u(1) - u1 = u(2) - - ! The h2 scheme is used to compute the right edge value - edge_values(1,2) = (u0*h1 + u1*h0) / (h0 + h1) + ! Extrapolate from 2 to 1 to estimate slope + slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( edge_values(1,2) - u0 ) - - edge_values(1,1) = u0 - 0.5 * slope - edge_values(1,2) = u0 + 0.5 * slope + edge_values(1,1) = u(1) - 0.5 * slope + edge_values(1,2) = u(1) + 0.5 * slope ppoly_coef(1,1) = edge_values(1,1) ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) - ! ------------------------------------------ - ! Right edge value in the left boundary cell - ! ------------------------------------------ - h0 = h(N-1) + hNeglect - h1 = h(N) + hNeglect - - u0 = u(N-1) - u1 = u(N) - - ! The h2 scheme is used to compute the right edge value - edge_values(N,1) = (u0*h1 + u1*h0) / (h0 + h1) - - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( u1 - edge_values(N,1) ) + ! Extrapolate from N-1 to N to estimate slope + slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) - edge_values(N,1) = u1 - 0.5 * slope - edge_values(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u(N) - 0.5 * slope + edge_values(N,2) = u(N) + 0.5 * slope ppoly_coef(N,1) = edge_values(N,1) ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) From 59308551e4380c93db1f82f3ad9f09c6bbc67ad7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 May 2020 16:13:42 +0000 Subject: [PATCH 132/256] Add time for unit_tests - Out of curiosity I want to be sure these weren't implicated in the long initialization cost. --- src/core/MOM.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4a98dbea6f..a9b9c7fec4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -406,6 +406,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +integer :: id_clock_unit_tests !>@} contains @@ -1720,7 +1721,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If True, exercises unit tests at model start up.", & default=.false., debuggingParam=.true.) if (do_unit_tests) then + id_clock_unit_tests = cpu_clock_id('(Ocean unit tests)', grain=CLOCK_MODULE) + call cpu_clock_begin(id_clock_unit_tests) call unit_tests(verbosity) + call cpu_clock_end(id_clock_unit_tests) endif call get_param(param_file, "MOM", "SPLIT", CS%split, & From a9d0caa990458fdeb0df29aa8c3cdfc574830f42 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 15:01:10 +0000 Subject: [PATCH 133/256] Fixed index capitalization in int_density_dz_generic_plm() - Soft index convention was not properly implemented in original PLM density integrals. Fixed to avoid confusion. --- src/core/MOM_density_integrals.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 486189b7f6..862097eeb2 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -416,7 +416,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) endif - do i=isq,ieq+1 + do i=Isq,Ieq+1 ! Use Boole'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 @@ -507,7 +507,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 12.0*r15(pos+3))) enddo ! Use Boole'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)) + & + 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 @@ -591,7 +591,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 12.0*r15(pos+3))) enddo ! Use Boole's rule to integrate the values. - inty_dpa(i,j) = 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 From 7fbcb013e69fff1e0dc2fcbaae5086caa373d753 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 15:04:58 +0000 Subject: [PATCH 134/256] Re-used pre-computed weights in int_density_dz_generic_plm() - Probably makes no difference but we re-computed weights repeatedly even though we'd pre-computed them (and used only once). - Reduces number of local variables. --- src/core/MOM_density_integrals.F90 | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 862097eeb2..7e9891486b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -373,7 +373,6 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 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 ! Non-dimensional weights of the top and bottom [nondim] real :: massWeightToggle ! A non-dimensional 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] @@ -460,7 +459,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & endif do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + w_left = wt_t(m) ; w_right = wt_b(m) 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 @@ -483,10 +482,8 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 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) + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo enddo enddo @@ -543,7 +540,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & endif do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + w_left = wt_t(m) ; w_right = wt_b(m) 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 @@ -564,10 +561,8 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 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) + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo enddo enddo From d25a36b2126a3640f63aaa6ce2156d5c2162b5c7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 21:30:42 +0000 Subject: [PATCH 135/256] Adds the PPM form of PGF by quadrature - Removes (now) unused functions for quadrature and polynomial evaluation - Has been tested by setting the logical use_PPM=.false. - reproduces PLM mode bitwise --- src/core/MOM_PressureForce_analytic_FV.F90 | 5 +- src/core/MOM_density_integrals.F90 | 518 ++++++++------------- 2 files changed, 197 insertions(+), 326 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 05dac0c0c3..160fe1c20d 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -647,8 +647,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa) + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 7e9891486b..4c5120ba09 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -596,9 +596,9 @@ end subroutine int_density_dz_generic_plm !> 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, HI, & - EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) +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, dz_subroundoff, bathyT, HI, EOS, US, & + dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] @@ -621,6 +621,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & 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] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & @@ -637,6 +640,8 @@ 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] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -645,75 +650,74 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! of the accelerations, and in the pressure used to calculated density (the ! latter being -z*rho_0*G_e). These two uses could be separated if need be. ! -! It is assumed that the salinity and temperature profiles are linear in the +! It is assumed that the salinity and temperature profiles are parabolic in the ! 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! +! a parabolic interpolation is used to compute intermediate values. ! Local variables - 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 :: T5(5) ! Temperatures along a line of subgrid locations [degC] + real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + 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 :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + 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 :: 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 ! 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 :: 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 - real :: s0, s1, s2 ! parabola coefficients for S [ppt] - real :: t0, t1, t2 ! parabola coefficients for T [degC] - 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 - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") + real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [ppt] + real :: s6 ! PPM curvature coefficient for S [ppt] + real :: t6 ! PPM curvature coefficient for T [degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S + 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 + logical :: use_PPM - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB rho_scale = US%kg_m3_to_R GxRho = US%RL2_T2_to_Pa * G_e * rho_0 rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + ! In event PPM calculation is bypassed with use_PPM=False + s6 = 0. + t6 = 0. + use_PPM = .true. ! This is a place-holder to allow later re-use of this function + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo ! 1. Compute vertical integrals do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - do n=1,5 p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 + ! Salinity and temperature points are reconstructed with PPM + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * ( S_b(i,j) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * ( T_b(i,j) + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -722,319 +726,185 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - 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)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + 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))) ) + endif enddo ; enddo ! end loops on j and i ! 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,j) ; intz(5) = dpa(i+1,j) + 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 + ! 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(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_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(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tml = ( (hWght*hR)*T(i+1,j) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom + Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i+1,j) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sml = ( (hWght*hR)*S(i+1,j) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom + Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i+1,j) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) + Tml = T(i,j); Tmr = T(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) + Sml = S(i,j); Smr = S(i+1,j) + endif + 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)) + w_left = wt_t(m) ; w_right = wt_b(m) ! 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. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr ! Pressure + dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo -stop if (rho_scale /= 1.0) then 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=rho_ref_mks) endif - ! Use Boole'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)) ) - enddo - 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 - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - 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=rho_ref_mks, scale=rho_scale ) - else - 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 - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) + ! Use Boole'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)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - intx_dpa(i,j) = intx_dpa(i,j) * G_e + ! Use Boole'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 ! 3. Compute horizontal integrals in the y direction - if (present(inty_dpa)) then - 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 + 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 + ! 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(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_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(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tml = ( (hWght*hR)*T(i,j+1) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom + Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i,j+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sml = ( (hWght*hR)*S(i,j+1) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom + Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i,j+1) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) + Tml = T(i,j); Tmr = T(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) + Sml = S(i,j); Smr = S(i,j+1) + endif - inty_dpa(i,j) = 0.0 + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) - enddo ; enddo - endif + ! 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. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr -end subroutine int_density_dz_generic_ppm + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + ! Pressure + dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo -!> Compute the integral of the quadratic function -subroutine compute_integral_quadratic( x, y, f, integral ) - real, dimension(4), intent(in) :: x !< The x-position of the corners - real, dimension(4), intent(in) :: y !< The y-position of the corners - real, dimension(9), intent(in) :: f !< The function at the quadrature points - real, intent(out) :: integral !< The returned integral + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif - ! Local variables - integer :: i, k - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo + ! Parabolic reconstructions in the vertical for T and S + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta + if (rho_scale /= 1.0) then + 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=rho_ref_mks) + endif - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) + ! Use Boole'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)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -end subroutine compute_integral_quadratic - - -!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) -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(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(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: - ! - ! (-1,1) 2 o------------o 1 (1,1) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) -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(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - 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(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: - ! - ! 5 (0,1) - ! (-1,1) 2 o------o------o 1 (1,1) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - phi(:) = 0.0 - dphidxi(:) = 0.0 - dphideta(:) = 0.0 - - phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) - phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic + enddo ; enddo ; endif +end subroutine int_density_dz_generic_ppm !> Calls the appropriate subroutine to calculate analytical and nearly-analytical !! integrals in pressure across layers of geopotential anomalies, which are From d945d70dfd3b99a6048271c655dea7262114c65c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 15 Jun 2020 19:23:42 +0000 Subject: [PATCH 136/256] Fixed line length issue in documentation --- src/core/MOM_density_integrals.F90 | 9 ++++++--- src/equation_of_state/MOM_EOS.F90 | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 4c5120ba09..87f09309e2 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1441,9 +1441,12 @@ 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) :: 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 [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) :: 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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 583bb8fcbc..84858aabcd 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -387,7 +387,7 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, 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(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [degC2] real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] From aaa0487769162b102f406b5b01041ec2a02701bb Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 15 Jun 2020 20:15:01 +0000 Subject: [PATCH 137/256] Fixed openmp in MOM_ALE.F90 - Use of new PLM functions led to out of date directives --- src/ALE/MOM_ALE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 7c4453a292..f130c2977a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1063,7 +1063,7 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) h_neglect = GV%kg_m2_to_H*1.0e-30 endif - !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) + !$OMP parallel do default(shared) private(slp,mslp) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 slp(1) = 0. do k = 2, GV%ke-1 From 80da001b2519faf90f9913a9f0c537f835691af2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:23:15 +0000 Subject: [PATCH 138/256] Updated to int_density_dz_generic_ppm() to use k and tv arguments - Now passing in 3D structures and tv so that we can access other fields in tv%. - Corrected calculation of curvatures s6, t6 for interpolated interior line integrals. - Tested with use_PPM=.false. and PLM edge values. - Using PLM edge values with use_PPM=.true. does give different answers because t6,s6 are non-zero albeit tiny. This is due to FP truncation errors. --- src/core/MOM_PressureForce_analytic_FV.F90 | 5 +- src/core/MOM_density_integrals.F90 | 136 ++++++++++----------- 2 files changed, 69 insertions(+), 72 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 160fe1c20d..0f22f46897 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -645,10 +645,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at G%HI, tv%eqn_of_state, US, 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), & + call int_density_dz_generic_ppm( k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) endif else diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 87f09309e2..efd8afcb2b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -15,7 +15,9 @@ module MOM_density_integrals 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_variables, only : thermo_var_ptrs use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -594,28 +596,25 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & end subroutine int_density_dz_generic_plm -!> Compute pressure gradient force integrals for the case where T and S +!> Compute pressure gradient force integrals for layer "k" and 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, dz_subroundoff, bathyT, HI, EOS, US, & +subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, & dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [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 @@ -708,15 +707,15 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if (use_PPM) then ! Curvature coefficient of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) endif - dz = z_t(i,j) - z_b(i,j) + dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + p5(n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz) ! Salinity and temperature points are reconstructed with PPM - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * ( S_b(i,j) + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * ( T_b(i,j) + t6 * wt_t(n) ) + S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) @@ -745,29 +744,29 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! 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(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tml = ( (hWght*hR)*T(i+1,j) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom - Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i+1,j) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sml = ( (hWght*hR)*S(i+1,j) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom - Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i+1,j) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) - Tml = T(i,j); Tmr = T(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) - Sml = S(i,j); Smr = S(i+1,j) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) endif do m=2,4 @@ -786,8 +785,8 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & S_bot = w_left*Sbl + w_right*Sbr ! Pressure - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo @@ -795,8 +794,8 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! Parabolic reconstructions in the vertical for T and S if (use_PPM) then ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) endif do n=1,5 S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) @@ -829,29 +828,29 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! 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(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tml = ( (hWght*hR)*T(i,j+1) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom - Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i,j+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sml = ( (hWght*hR)*S(i,j+1) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom - Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i,j+1) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) - Tml = T(i,j); Tmr = T(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) - Sml = S(i,j); Smr = S(i,j+1) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) endif do m=2,4 @@ -870,19 +869,18 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & S_bot = w_left*Sbl + w_right*Sbr ! Pressure - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo + ! Parabolic reconstructions in the vertical for T and S if (use_PPM) then ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) endif - - ! Parabolic reconstructions in the vertical for T and S do n=1,5 S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) From 783983e3e9f2d8977d93e0123a99778381cf5855 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:36:39 +0000 Subject: [PATCH 139/256] Renamed MOM_PressureGradient_AFV - Since the majority of code is not about the analytic integration I thought it time to rename this module --- ...MOM_PressureForce_analytic_FV.F90 => MOM_PressureForce_FV.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/core/{MOM_PressureForce_analytic_FV.F90 => MOM_PressureForce_FV.F90} (100%) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_FV.F90 similarity index 100% rename from src/core/MOM_PressureForce_analytic_FV.F90 rename to src/core/MOM_PressureForce_FV.F90 From e8336777c9bf291299a70c3236997213b7174d64 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:42:02 +0000 Subject: [PATCH 140/256] After renaming module, change _AFV_ to _FV_ - Continuation of rename of module --- src/core/MOM_PressureForce.F90 | 20 +++++------ src/core/MOM_PressureForce_FV.F90 | 55 ++++++++++++++++--------------- 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 6902e13341..f8690ca0cd 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -7,9 +7,9 @@ module MOM_PressureForce use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss -use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_end -use MOM_PressureForce_AFV, only : PressureForce_AFV_CS +use MOM_PressureForce_FV, only : PressureForce_FV_Bouss, PressureForce_FV_nonBouss +use MOM_PressureForce_FV, only : PressureForce_FV_init, PressureForce_FV_end +use MOM_PressureForce_FV, only : PressureForce_FV_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 @@ -28,10 +28,10 @@ module MOM_PressureForce type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. - logical :: blocked_AFV !< If true, used the blocked version of the ANALYTIC_FV_PGF + logical :: blocked_FV !< If true, used the blocked version of the ANALYTIC_FV_PGF !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force - type(PressureForce_AFV_CS), pointer :: PressureForce_AFV_CSp => NULL() + type(PressureForce_FV_CS), pointer :: PressureForce_FV_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 @@ -64,10 +64,10 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e 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, & + call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) endif else @@ -111,8 +111,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) "described in Adcroft et al., O. Mod. (2008).", default=.true.) if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_AFV_CSp, tides_CSp) + call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_FV_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_Mont_CSp, tides_CSp) @@ -125,7 +125,7 @@ subroutine PressureForce_end(CS) type(PressureForce_CS), pointer :: CS !< Pressure force control structure if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) + call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0f22f46897..9f6ad779d0 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1,5 +1,5 @@ -!> Analytically integrated finite volume pressure gradient -module MOM_PressureForce_AFV +!> Finite volume pressure gradient (integrated by quadrature or analytically) +module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. @@ -24,8 +24,8 @@ module MOM_PressureForce_AFV #include -public PressureForce_AFV_init, PressureForce_AFV_end -public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss +public PressureForce_FV_init, PressureForce_FV_end +public PressureForce_FV_Bouss, PressureForce_FV_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 @@ -33,7 +33,7 @@ module MOM_PressureForce_AFV ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Finite volume pressure gradient control structure -type, public :: PressureForce_AFV_CS ; private +type, public :: PressureForce_FV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -57,7 +57,7 @@ module MOM_PressureForce_AFV integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure -end type PressureForce_AFV_CS +end type PressureForce_FV_CS contains @@ -70,7 +70,7 @@ module MOM_PressureForce_AFV !! 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_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_nonBouss(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 @@ -78,7 +78,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_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]. @@ -157,7 +157,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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.") + "MOM_PressureForce_FV_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 @@ -240,7 +240,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& + call MOM_error(FATAL, "PressureForce_FV_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), & @@ -397,7 +397,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_nonBouss +end subroutine PressureForce_FV_nonBouss !> \brief Boussinesq analytically-integrated finite volume form of pressure gradient !! @@ -407,7 +407,7 @@ end subroutine PressureForce_AFV_nonBouss !! 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_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_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 @@ -415,7 +415,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_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]. @@ -486,7 +486,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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.") + "MOM_PressureForce_FV_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 @@ -739,17 +739,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_Bouss +end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_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_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_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" @@ -767,7 +767,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C if (associated(tides_CSp)) CS%tides_CSp => tides_CSp endif - mdl = "MOM_PressureForce_AFV" + mdl = "MOM_PressureForce_FV" 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 "//& @@ -782,7 +782,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "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 "//& + "integrals near the bathymetry in FV 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 "//& @@ -812,20 +812,21 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) -end subroutine PressureForce_AFV_init +end subroutine PressureForce_FV_init !> Deallocates the finite volume pressure gradient control structure -subroutine PressureForce_AFV_end(CS) - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume pressure control structure that +subroutine PressureForce_FV_end(CS) + type(PressureForce_FV_CS), pointer :: CS !< Finite volume pressure control structure that !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) -end subroutine PressureForce_AFV_end +end subroutine PressureForce_FV_end -!> \namespace mom_pressureforce_afv +!> \namespace mom_pressureforce_fv !! !! 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. +!! due to pressure gradients using a vertically integrated finite volume form, +!! as described by Adcroft et al., 2008. Integration in the vertical is made +!! either by quadrature or analytically. !! !! This form eliminates the thermobaric instabilities that had been a problem with !! previous forms of the pressure gradient force calculation, as described by @@ -839,4 +840,4 @@ end subroutine PressureForce_AFV_end !! ocean models. Ocean Modelling, 8, 279-300. !! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 -end module MOM_PressureForce_AFV +end module MOM_PressureForce_FV From 660150feefa83bbf692ec385c5e762857efbcb77 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:51:12 +0000 Subject: [PATCH 141/256] Removed conditional scaling from int_density_dz_generic_ppm() - This routine was suffering from if's inside loops. I've removed this one since it was just obfuscation, pretending to care about performance and actually reducing it. --- src/core/MOM_density_integrals.F90 | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index efd8afcb2b..bc2fd49257 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -717,11 +717,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - 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=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) @@ -802,11 +798,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - 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=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole'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)) ) @@ -886,11 +878,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - 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=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole'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)) ) From 7ae38fe90dc7e8ed6cf3973ea597a17c879e501c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 02:49:18 +0000 Subject: [PATCH 142/256] Adds SGS variance to tv and adds Brankart effect to PGF - Makes use of the Stanley equation of state to include effects of SGS temperature variance, salinity variance and T-S covariance. --- src/core/MOM_density_integrals.F90 | 45 +++++++++++++++++++++++++++--- src/core/MOM_variables.F90 | 8 +++++- 2 files changed, 48 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index bc2fd49257..b312d0d73b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -656,6 +656,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! Local variables real :: T5(5) ! Temperatures along a line of subgrid locations [degC] real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + real :: T25(5) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [degC ppt] + real :: S25(5) ! SGS salinity variance along a line of subgrid locations [ppt2] 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 :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] @@ -680,7 +683,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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 - logical :: use_PPM + logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -698,6 +703,14 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & t6 = 0. use_PPM = .true. ! This is a place-holder to allow later re-use of this function + use_varT = allocated(tv%varT) + use_covarTS = allocated(tv%covarTS) + use_varS = allocated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) @@ -717,7 +730,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = tv%varT(i,j,k) + if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) + if (use_varT) S25(:) = tv%varS(i,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, 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=rho_ref_mks, scale=rho_scale) + endif ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) @@ -798,7 +819,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, 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=rho_ref_mks, scale=rho_scale) + endif ! Use Boole'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)) ) @@ -878,7 +907,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, 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=rho_ref_mks, scale=rho_scale) + endif ! Use Boole'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)) ) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 97e5b36db5..e3a5c6f23e 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables type, public :: thermo_var_ptrs ! 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 :: S(:,:,:) => NULL() !< Salinity [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 @@ -116,6 +116,12 @@ module MOM_variables !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to !! calculate_surface_state [degC R Z ~> degC kg m-2]. + ! The following variables are most normally not used but when they are they + ! will be either set by parameterizations or prognostic. + real, allocatable :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. + real, allocatable :: varS(:,:,:) !< SGS variance of salinity [ppt2]. + real, allocatable :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter + !! [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From b7afafb328903d9d7a194447d55ff79f1a8ab774 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 2 Aug 2019 15:10:04 -0600 Subject: [PATCH 143/256] Adds the deterministic part of the Stanley param. --- .../lateral/MOM_thickness_diffuse.F90 | 44 ++++++++++++++++++- 1 file changed, 42 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7d5fc8b846..ee2a100cab 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -10,6 +10,7 @@ module MOM_thickness_diffuse 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, EOS_domain +use MOM_EOS, only : calculate_density_second_derivs 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 @@ -19,7 +20,6 @@ module MOM_thickness_diffuse use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type - implicit none ; private #include @@ -77,6 +77,9 @@ module MOM_thickness_diffuse !! 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. + logical :: use_Stanley !< If true, use a correction to the horizontal density gradient + !! when computing the Ferrari et al., 2010 streamfunction. + 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] @@ -668,6 +671,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] + real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP ! derivatives for EOS. + real :: dT2 ! length scale times temp. derivative, squared. + real :: dTdy2, dTdx2 ! pot. temp. derivatives, squared. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics 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 @@ -848,6 +855,20 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) + ! Correction to the horizontal density gradient due to the nonlinear EOS + if (CS%use_Stanley) then + ! Calculate dT/dx and dT/dy at u-points + dTdy2 = 0.0625*(G%IdyCv(i,J)*(T(i,j+1,k-1)-T(i,j,k-1))+ & + G%IdyCv(i,J-1)*(T(i,j,k-1)-T(i,j-1,k-1))+ & + G%IdyCv(i+1,J)*(T(i+1,j+1,k-1)-T(i+1,j,k-1))+ & + G%IdyCv(i+1,J-1)*(T(i+1,j,k-1)-T(i+1,j-1,k-1)))**2 + dT2 = (T(i+1,j,k-1)-T(i,j,k-1))**2 + (G%dyCu(I,j)**2)*dTdy2 + + call calculate_density_second_derivs(T_u(I), S_u(I), pres_u(I),dbeta_dS, & + dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) + + drdx = drdx + (dT2*dalpha_dT) + endif ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. @@ -1028,7 +1049,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn) if (calc_derivatives) then do i=is,ie @@ -1100,6 +1121,21 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) + ! Correction to the horizontal density gradient due to the nonlinear EOS + if (CS%use_Stanley) then + ! Calculate dT/dx and dT/dy at v-points + dTdx2 = 0.0625*(G%IdxCv(i,J)*(T(i+1,j,k-1)-T(i,j,k-1))+ & + G%IdxCv(i,J-1)*(T(i,j,k-1)-T(i-1,j,k-1))+ & + G%IdxCv(i+1,J)*(T(i+1,j+1,k-1)-T(i,j+1,k-1))+ & + G%IdxCv(i+1,J-1)*(T(i,j+1,k-1)-T(i-1,j+1,k-1)))**2 + dT2 = (T(i,j+1,k-1)-T(i,j,k-1))**2 + (G%dxCv(I,j)**2)*dTdx2 + + call calculate_density_second_derivs(T_v(I), S_v(I), pres_v(I),dbeta_dS, & + dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) + + drdy = drdy + (dT2*dalpha_dT) + endif + ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. mag_grad2 = drdy**2 + (US%L_to_Z*drdz)**2 @@ -1887,6 +1923,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "USE_STANLEY", CS%use_Stanley, & + "If true, use a correction to the horizontal density gradient \n"// & + "when computing the Ferrari et al., 2010 streamfunction.", & + default=.false.) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) From f462c4d1311ae55f398fc265803f8b35e9249cda Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 23 Jan 2020 15:35:24 +0000 Subject: [PATCH 144/256] Re-wrote Stanley parameterization using vertical weights - This now calculates the gradient of SGS temperature variance using the same discretization as used for the gradient of density along coordinate surfaces. - Added run-time coefficient for Stanley parameterization - Fixed openmp directives. - Alters halo over which vert_fill_TS() is called. - Add Stanley parameter to tc2 to test new code. --- .testing/tc2/MOM_input | 4 + .../lateral/MOM_thickness_diffuse.F90 | 118 +++++++++++------- 2 files changed, 74 insertions(+), 48 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 6678c00578..5c5f45bd11 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -426,6 +426,10 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. +STANLEY_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley parameterization. Negative + ! values disable the scheme. ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ee2a100cab..ad00acc88c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -77,8 +77,9 @@ module MOM_thickness_diffuse !! 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. - logical :: use_Stanley !< If true, use a correction to the horizontal density gradient - !! when computing the Ferrari et al., 2010 streamfunction. + real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean + !! temperature gradient in the deterministic part of the Stanley parameterization. + !! Negative values disable the scheme." [nondim] 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] @@ -602,10 +603,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] - drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] - drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & @@ -671,9 +675,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP ! derivatives for EOS. - real :: dT2 ! length scale times temp. derivative, squared. - real :: dTdy2, dTdx2 ! pot. temp. derivatives, squared. + real :: dTdi2, dTdj2 ! pot. temp. differences, squared. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics @@ -683,7 +686,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! 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 + logical :: use_Stanley + integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB @@ -701,6 +705,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV present_int_slope_v = PRESENT(int_slope_v) present_slope_x = PRESENT(slope_x) present_slope_y = PRESENT(slope_y) + use_Stanley = CS%Stanley_det_coeff >= 0. nk_linear = max(GV%nkml, 1) @@ -714,15 +719,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, 1, larger_h_denom=.true.) + halo = 1 ! Default halo to fill is 1 + if (use_Stanley) halo = 2 ! Need wider valid halo for gradients of T + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, & -!$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 ) +!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & +!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & +!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & +!$OMP private(dTdi2,dTdj2) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 @@ -735,6 +743,20 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_frac(i,j,1) = 1.0 pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo + if (use_Stanley) then +!$OMP do + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 @@ -766,9 +788,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$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,EOSdom_u, & +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_u,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & @@ -782,7 +806,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_Stanley) ! Calculate the zonal fluxes and gradients. if (calc_derivatives) then @@ -794,6 +818,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_u, S_u, pres_u, & + scrap, scrap, drho_dT_dT_u, scrap, scrap, & + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + endif do I=is-1,ie if (calc_derivatives) then @@ -812,7 +843,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) endif - + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdi_u(I,k) = drdiB if (k > nk_linear) then @@ -855,20 +891,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) - ! Correction to the horizontal density gradient due to the nonlinear EOS - if (CS%use_Stanley) then - ! Calculate dT/dx and dT/dy at u-points - dTdy2 = 0.0625*(G%IdyCv(i,J)*(T(i,j+1,k-1)-T(i,j,k-1))+ & - G%IdyCv(i,J-1)*(T(i,j,k-1)-T(i,j-1,k-1))+ & - G%IdyCv(i+1,J)*(T(i+1,j+1,k-1)-T(i+1,j,k-1))+ & - G%IdyCv(i+1,J-1)*(T(i+1,j,k-1)-T(i+1,j-1,k-1)))**2 - dT2 = (T(i+1,j,k-1)-T(i,j,k-1))**2 + (G%dyCu(I,j)**2)*dTdy2 - - call calculate_density_second_derivs(T_u(I), S_u(I), pres_u(I),dbeta_dS, & - dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) - - drdx = drdx + (dT2*dalpha_dT) - endif ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. @@ -1034,9 +1056,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$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,EOSdom_v,& +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_v,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & @@ -1049,7 +1073,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_Stanley) if (calc_derivatives) then do i=is,ie @@ -1060,6 +1084,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_v, S_v, pres_v, & + scrap, scrap, drho_dT_dT_v, scrap, scrap, & + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + endif do i=is,ie if (calc_derivatives) then ! Estimate the horizontal density gradients along layers. @@ -1077,6 +1108,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) endif + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdj_v(i,k) = drdjB @@ -1121,21 +1158,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) - ! Correction to the horizontal density gradient due to the nonlinear EOS - if (CS%use_Stanley) then - ! Calculate dT/dx and dT/dy at v-points - dTdx2 = 0.0625*(G%IdxCv(i,J)*(T(i+1,j,k-1)-T(i,j,k-1))+ & - G%IdxCv(i,J-1)*(T(i,j,k-1)-T(i-1,j,k-1))+ & - G%IdxCv(i+1,J)*(T(i+1,j+1,k-1)-T(i,j+1,k-1))+ & - G%IdxCv(i+1,J-1)*(T(i,j+1,k-1)-T(i-1,j+1,k-1)))**2 - dT2 = (T(i,j+1,k-1)-T(i,j,k-1))**2 + (G%dxCv(I,j)**2)*dTdx2 - - call calculate_density_second_derivs(T_v(I), S_v(I), pres_v(I),dbeta_dS, & - dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) - - drdy = drdy + (dT2*dalpha_dT) - endif - ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. mag_grad2 = drdy**2 + (US%L_to_Z*drdz)**2 @@ -1923,10 +1945,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) - call get_param(param_file, mdl, "USE_STANLEY", CS%use_Stanley, & - "If true, use a correction to the horizontal density gradient \n"// & - "when computing the Ferrari et al., 2010 streamfunction.", & - default=.false.) + call get_param(param_file, mdl, "STANLEY_DET_COEFF", CS%Stanley_det_coeff, & + "The coefficient correlating SGS temperature variance with the mean "//& + "temperature gradient in the deterministic part of the Stanley parameterization. "//& + "Negative values disable the scheme.", units="nondim", default=-1.0) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) From 75a20d8d9e2db7ea73072b017b2e016899e2231f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 14:53:48 +0000 Subject: [PATCH 145/256] Added STANLEY_PRM_DET_COEFF run time parameter - Renamed STANLEY_DET_COEFF to STANLEY_PRM_DET_COEFF to indicate this is for the Stanley parameterization as opposed to a related approach by Stanley for implementing the Brankart PGF correction. --- .testing/tc2/MOM_input | 2 +- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 5c5f45bd11..bef1dc9aef 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -426,7 +426,7 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. -STANLEY_DET_COEFF = 0.5 ! [nondim] default = -1.0 +STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ad00acc88c..e0a2fcdef9 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1945,7 +1945,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) - call get_param(param_file, mdl, "STANLEY_DET_COEFF", CS%Stanley_det_coeff, & + call get_param(param_file, mdl, "STANLEY_PRM_DET_COEFF", CS%Stanley_det_coeff, & "The coefficient correlating SGS temperature variance with the mean "//& "temperature gradient in the deterministic part of the Stanley parameterization. "//& "Negative values disable the scheme.", units="nondim", default=-1.0) From c94e0cbdbd93512ad90956f83713c832398b8108 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 14:56:31 +0000 Subject: [PATCH 146/256] Adds the T variance Stanley component to PGF - PGF_STANLEY_T2_DET_COEFF>=0. now adds the temperature variance contribution to the Brankart correction using the Stanley linearization of the EOS and parameterization of SGS variance. --- .testing/tc2/MOM_input | 1 + src/core/MOM_PressureForce_FV.F90 | 27 ++++++++++++++++++++++++--- src/core/MOM_density_integrals.F90 | 12 ++++++------ src/core/MOM_variables.F90 | 8 ++++---- 4 files changed, 35 insertions(+), 13 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index bef1dc9aef..d5a904d841 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -430,6 +430,7 @@ STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 9f6ad779d0..132b403cf4 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -54,7 +54,9 @@ module MOM_PressureForce_FV 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 - + real :: Stanley_T2_det_coeff !< The coefficient correlating SGS temperature variance with + !! the mean temperature gradient in the deterministic part of + !! the Stanley form of the Brankart correction. integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -474,7 +476,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 :: dTdi2, dTdj2 ! Differences in T variance [degC2] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -495,6 +497,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + if (CS%Stanley_T2_det_coeff>=0.) then + if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif + h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0 / GV%Rho0 @@ -801,7 +818,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "boundary cells is extrapolated, rather than using PCM "//& "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) - + call get_param(param_file, mdl, "PGF_STANLEY_T2_DET_COEFF", CS%Stanley_T2_det_coeff, & + "The coefficient correlating SGS temperature variance with "// & + "the mean temperature gradient in the deterministic part of "// & + "the Stanley form of the Brankart correction. "// & + "Negative values disable the scheme.", units="nondim", default=-1.0) 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) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index b312d0d73b..d8eb2d80f8 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -703,9 +703,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & t6 = 0. use_PPM = .true. ! This is a place-holder to allow later re-use of this function - use_varT = allocated(tv%varT) - use_covarTS = allocated(tv%covarTS) - use_varS = allocated(tv%varS) + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) use_stanley_eos = use_varT .or. use_covarTS .or. use_varS T25(:) = 0. TS5(:) = 0. @@ -733,7 +733,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = tv%varT(i,j,k) if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) - if (use_varT) S25(:) = tv%varS(i,j,k) + if (use_varS) S25(:) = tv%varS(i,j,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -822,7 +822,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) - if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -910,7 +910,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) - if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index e3a5c6f23e..a290515306 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -118,10 +118,10 @@ module MOM_variables !! calculate_surface_state [degC R Z ~> degC kg m-2]. ! The following variables are most normally not used but when they are they ! will be either set by parameterizations or prognostic. - real, allocatable :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. - real, allocatable :: varS(:,:,:) !< SGS variance of salinity [ppt2]. - real, allocatable :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter - !! [degC ppt]. + real, pointer :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter + !! [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From 073b4223192758c0bb496902d94f1554ca1f7c2b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sat, 20 Jun 2020 03:49:13 +0000 Subject: [PATCH 147/256] Nullified new pointers in tv - After starting with allocatables and switching to pointers I'd forgotten to nullify them. --- src/core/MOM_variables.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a290515306..26c2344f44 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -118,10 +118,10 @@ module MOM_variables !! calculate_surface_state [degC R Z ~> degC kg m-2]. ! The following variables are most normally not used but when they are they ! will be either set by parameterizations or prognostic. - real, pointer :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. - real, pointer :: varS(:,:,:) !< SGS variance of salinity [ppt2]. - real, pointer :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter - !! [degC ppt]. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential + !! temperature [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From b7341c2ed1ec09725e5a1f205fa118b0902d0cea Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 6 Jul 2020 19:34:22 -0400 Subject: [PATCH 148/256] Correct scaling for second derivs in Stanley param - Passing the scale= to calculate_density_second_derivs() was the double scaling the density contribution from SGS variance in the Stanley parameterization. --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index e0a2fcdef9..b59ab34c91 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -823,7 +823,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_u, S_u, pres_u, & scrap, scrap, drho_dT_dT_u, scrap, scrap, & - (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) endif do I=is-1,ie @@ -1089,7 +1089,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_v, S_v, pres_v, & scrap, scrap, drho_dT_dT_v, scrap, scrap, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + is, ie-is+1, tv%eqn_of_state) endif do i=is,ie if (calc_derivatives) then From 6356092d902eb697ede213d591d347791faecde0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 08:49:38 -0400 Subject: [PATCH 149/256] Corrected indentation in MOM_EOS - select case statements were indented as if once inside a loop. --- src/equation_of_state/MOM_EOS.F90 | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 84858aabcd..3427e46a7b 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -252,27 +252,26 @@ 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 !! in combination with scaling given by US [various] - 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, & - 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 + 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 if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 rho(j) = scale * rho(j) From 7544c7917fa6c37548b5baae85172710da8270ca Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 08:52:41 -0400 Subject: [PATCH 150/256] Fixed pressure scaling for calculate_stanley_density_array() - The pressure scaling was wrong when trying to call calculate_density_second_derivs_array() from within calculate_stanley_density_array() because the latter should not do any scaling but the former always did. I had to call the lower level functions provided by WRIGHT, TEOS10, etc to avoid get the scaling tests to pass. --- src/core/MOM_density_integrals.F90 | 1 - src/equation_of_state/MOM_EOS.F90 | 27 ++++++++++++++++++++------- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index d8eb2d80f8..9e86a94ec1 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -10,7 +10,6 @@ module MOM_density_integrals use MOM_EOS, only : calculate_density use MOM_EOS, only : calculate_spec_vol use MOM_EOS, only : calculate_specific_vol_derivs -use MOM_EOS, only : calculate_density_second_derivs 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 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3427e46a7b..7f70281783 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -291,7 +291,7 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] - real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [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 @@ -305,15 +305,28 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - ! Branching to the correct EOS happens within each of these calls - ! and will appropriately error if the second derivatives are not available. - call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, start, npts, EOS) - call calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) + 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) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") + end select ! Equation 25 of Stanley et al., 2020. do j=start,start+npts-1 - rho(j) = rho(j) + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + rho(j) = rho(j) & + + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) enddo if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 From 31b7e0a14a792864d2aadaeddb4d2d133566bf65 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 17:11:03 -0400 Subject: [PATCH 151/256] Re-factored int_density_dz_generic_plm() - In preparing to add Brankartc terms to PLM form of presure gradient I'm adapting the routine to look like the PPM routine which takes 3D arguments but only works on layer "k". --- src/core/MOM_PressureForce_FV.F90 | 8 +-- src/core/MOM_density_integrals.F90 | 94 ++++++++++++++++-------------- 2 files changed, 53 insertions(+), 49 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 132b403cf4..4da503f498 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -657,12 +657,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! 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, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm( k, tv, T_t, T_b, S_t, S_b, e, & + call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 9e86a94ec1..bd2ef2fd48 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -295,22 +295,23 @@ end subroutine int_density_dz_generic_pcm !> 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, HI, EOS, US, dpa, & +subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(SZI_(HI),SZJ_(HI)), & + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [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 @@ -402,12 +403,12 @@ 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 do i = Isq,Ieq+1 - dz(i) = z_t(i,j) - z_b(i,j) + dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated - 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) + S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) + T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) enddo enddo if (rho_scale /= 1.0) then @@ -440,28 +441,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(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - 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 + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom else - 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) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - 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)) + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -474,7 +475,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(i,j) + w_right*z_t(i+1,j)) + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) ! Pressure do n=2,5 @@ -521,28 +522,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(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - 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 + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom else - 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) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - 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)) + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -555,10 +556,12 @@ 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(i,j) + w_right*z_t(i,j+1)) + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo + 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 @@ -576,6 +579,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(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=HI%isc,HI%iec intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) From 5d4f1eb11a987e5b60b298dde7276b74d7a15fa8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 17:53:29 -0400 Subject: [PATCH 152/256] Implement Brankart terms in PLM form of PGF - The Brankart PGF terms are now implemented in the PLM recontruction routines, just as they were for the PPM form. --- src/core/MOM_density_integrals.F90 | 87 +++++++++++++++++++++++++----- 1 file changed, 75 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index bd2ef2fd48..d7d9c95b34 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -353,12 +353,18 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! Local variables 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 :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] 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 :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid locations [ppt2] 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] @@ -381,6 +387,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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] + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: pos @@ -395,6 +403,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (useMassWghtInterp) massWeightToggle = 1. endif + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. + do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) @@ -410,11 +429,25 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) enddo + if (use_varT) T25(i*5+1:i*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(i*5+1:i*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_Stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks) + endif else - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif endif do i=Isq,Ieq+1 @@ -487,13 +520,27 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) 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) + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks) + endif else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + 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) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif endif do I=Isq,Ieq @@ -568,16 +615,32 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) enddo enddo - if (rho_scale /= 1.0) then - call calculate_density(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) + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(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(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif else - call calculate_density(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) + if (rho_scale /= 1.0) then + call calculate_density(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(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 endif do i=HI%isc,HI%iec From ee1232a3a13da44ec1156a6568a6e9b56521e6c3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 8 Jul 2020 16:39:06 -0400 Subject: [PATCH 153/256] Cleaned up tc2 MOM_input - Added documentation lines for PGF_STANLEY_T2_DET_COEFF --- .testing/tc2/MOM_input | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index d5a904d841..1818390192 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -297,6 +297,10 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! v-points, and similarly at v-points. This option would ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley form of the Brankart + ! correction. Negative values disable the scheme. ! === module MOM_hor_visc === LAPLACIAN = True @@ -430,7 +434,6 @@ STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. -PGF_STANLEY_T2_DET_COEFF = 0.5 ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 From f0bab127117a700716f100ed11b776b2857220cf Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 16:47:05 -0400 Subject: [PATCH 154/256] Added comments to highlight a dimensionally problematic constant - Per feedback to #1156 --- src/ALE/PLM_functions.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 952202d325..07b27a6912 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -55,6 +55,8 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ endif ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. end function PLM_slope_wa @@ -104,6 +106,8 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ endif ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. end function PLM_slope_cw From e8adc48a36dfe4b12459651ee2893b6670c0e2a1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:31:53 -0400 Subject: [PATCH 155/256] Corrected scaling in _1d and _scalar EOS functions - Per feedback on #1156, corrected scaling for calculate_stanley_density_scalar() and calculate_stanley_density_1d(). --- src/equation_of_state/MOM_EOS.F90 | 78 ++++++++++++++++++++----------- 1 file changed, 50 insertions(+), 28 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 7f70281783..40ac04e9e8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -183,7 +183,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, p_scale*pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) case (EOS_WRIGHT) @@ -222,20 +222,38 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r !! from kg m-3 to the desired units [R m3 kg-1] ! Local variables real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + 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] if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_density_scalar called with an unassociated EOS_type EOS.") + "calculate_stanley_density_scalar called with an unassociated EOS_type EOS.") - ! Branching to the correct EOS happens within each of these calls - ! and will appropriately error if the second derivatives are not available. - call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, EOS) - call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + p_scale = EOS%RL2_T2_to_Pa + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, p_scale*pressure, rho, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select ! Equation 25 of Stanley et al., 2020. rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) - if (present(scale)) rho = scale * rho + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho end subroutine calculate_stanley_density_scalar @@ -412,8 +430,6 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, ! Local variables 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] real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p integer :: i, is, ie, npts @@ -428,26 +444,32 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, endif p_scale = EOS%RL2_T2_to_Pa - rho_unscale = EOS%R_to_kg_m3 + do i=is,ie + pres(i) = p_scale * pressure(i) + enddo - 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) - call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, is, npts, EOS) - else ! 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 - call calculate_density_second_derivs_array(T, S, pres, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, is, npts, EOS) - if (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. - 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. - call calculate_density_array(T, S, pres, rho, is, npts, EOS) - endif - endif + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, 1, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. do i=is,ie - rho(i) = rho(i) + ( d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + d2RdSS(i) * Svar(i) ) ) + rho(i) = rho(i) & + + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) enddo rho_scale = EOS%kg_m3_to_R From ec0946c9c9d7e0f50a78451be67bc80ab8bd91dd Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:36:57 -0400 Subject: [PATCH 156/256] Removed unused member in PressureForce_CS - Per feedback on #1156. --- src/core/MOM_PressureForce.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index f8690ca0cd..1963a8a773 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -28,8 +28,6 @@ module MOM_PressureForce type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. - logical :: blocked_FV !< If true, used the blocked version of the ANALYTIC_FV_PGF - !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force type(PressureForce_FV_CS), pointer :: PressureForce_FV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force From 4307fa5e528778bd8668ee8caedfee2a0b5edfe6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:38:52 -0400 Subject: [PATCH 157/256] Added FATAL if trying to use parameterization in non-Boussinesq mode - Per feedback on #1156 --- src/core/MOM_PressureForce_FV.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4da503f498..6c01580e29 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -160,6 +160,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") + if (CS%Stanley_T2_det_coeff>=0.) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + "implemented in non-Boussinesq mode.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif From b3a584d437ec716ad84f1afd78621b02dd5f1bbd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Jul 2020 17:44:31 -0400 Subject: [PATCH 158/256] (*)Set maximum value of au_visc Set a hard-coded maximum value of CS%a_u and CS%a_v of 1e37 m s-1 so that these can be represented in diagnostics that are written with 32-bit floating point numbers. These values are so large that all answers are bitwise identical in the MOM6-examples test cases, but it is possible that answers could change. --- .../vertical/MOM_vert_friction.F90 | 33 ++++++++++--------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6e1fd8fac9..b1a37c7d5e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -629,6 +629,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) real :: z2 ! The distance from the bottom, normalized by Hbbl, nondim. real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2. real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: a_cpl_max ! The maximum drag doefficient across interfaces, set so that it will be + ! representable as a 32-bit float in MKS units [Z T-1 ~> m 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]. @@ -648,6 +650,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff + a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -811,13 +814,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(I,K) + & + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) +! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & +! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) elseif (do_i(I)) then - CS%a_u(I,j,K) = a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) endif ; enddo ; enddo 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? @@ -827,7 +830,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, 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) + h_neglect ; enddo ; enddo endif @@ -979,13 +982,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & -! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) +! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & + ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) elseif (do_i(i)) then - CS%a_v(i,J,K) = a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) endif ; enddo ; enddo 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? @@ -995,7 +998,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, 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) + h_neglect ; enddo ; enddo endif @@ -1109,10 +1112,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, nz = G%ke h_neglect = GV%H_subroundoff - ! The maximum coupling coefficent was originally introduced to avoid - ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 - ! sets the maximum coupling coefficient increment to 1e10 m per timestep. if (CS%answers_2018) then + ! The maximum coupling coefficent was originally introduced to avoid + ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 + ! sets the maximum coupling coefficient increment to 1e10 m per timestep. I_amax = (1.0e-10*US%Z_to_m) * dt else I_amax = 0.0 From 553166ae8e8a871a0d1e39a091cbe707ef8a3159 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:51:59 -0400 Subject: [PATCH 159/256] Added comments for local variables - Per feedback on #1156. --- src/ALE/PLM_functions.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 07b27a6912..da60f9614a 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -27,7 +27,9 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ real, intent(in) :: u_c !< Value of center cell [units of u] real, intent(in) :: u_r !< Value of right cell [units of u] ! Local variables - real :: sigma_l, sigma_c, sigma_r, u_min, u_max + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] ! Side differences sigma_r = u_r - u_c @@ -71,7 +73,10 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ real, intent(in) :: u_c !< Value of center cell [units of u] real, intent(in) :: u_r !< Value of right cell [units of u] ! Local variables - real :: sigma_l, sigma_c, sigma_r, u_min, u_max, h_cn + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + real :: h_cn ! Thickness of center cell [units of grid thickness] h_cn = h_c + h_neglect @@ -121,7 +126,9 @@ real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) real, intent(in) :: s_c !< PLM slope of center cell [units of u] real, intent(in) :: s_r !< PLM slope of right cell [units of u] ! Local variables - real :: e_r, e_l, edge, almost_two, slp + real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] + real :: almost_two ! The number 2, almost. + real :: slp ! Magnitude of PLM central slope [units of u] almost_two = 2. * ( 1. - epsilon(s_c) ) @@ -157,7 +164,8 @@ real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c real, intent(in) :: u_l !< Value of left cell [units of u] real, intent(in) :: u_c !< Value of center cell [units of u] ! Local variables - real :: left_edge, hl, hc + real :: left_edge ! Left edge value [units of u] + real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] ! Avoid division by zero for vanished cells hl = h_l + h_neglect From 8df3e7f550b41018365a428f22cd762804e68050 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 09:36:02 -0400 Subject: [PATCH 160/256] +Eliminate uhbt_IC and ubt_IC from restart files Eliminated the unused variables CS%uhbt_IC and CS%vhbt_IC from the barotropic control structure and from the MOM6 restart files. Also placed a logical test for CS%Gradual_BT_ICs around all references to CS%ubt_IC and CS%vbt_IC and eliminated these variables from the restart files when they would not be used. Additionally some unused arguments were removed from internal subroutines and some spelling or index case errors were corrected. All answers are bitwise identical, but the MOM6 restart files have fewer variables and some unused entries in the MOM_parameter_doc files have changed. --- src/core/MOM_barotropic.F90 | 356 +++++++++++++++++++----------------- 1 file changed, 193 insertions(+), 163 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 50ad121b77..4e4233bc38 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -108,9 +108,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -121,9 +118,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -258,9 +252,8 @@ module MOM_barotropic !! times the time-derivatives of thicknesses. The !! default is 0.1, and there will probably be real !! problems if this were set close to 1. - logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set - !! limits on the magnitude of the corrective mass - !! fluxes. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set limits + !! on the magnitude of the corrective mass fluxes. logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating !! the barotropic velocities that were used to !! calculate uh0 and vh0. False is probably the @@ -313,6 +306,7 @@ module MOM_barotropic integer :: id_BTC_ubt_EE = -1, id_BTC_ubt_WW = -1 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_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 !>@} @@ -486,6 +480,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & + tmp_h, & ! A temporary array at h points. e_anom ! The anomaly in the sea surface height or column mass ! averaged between the beginning and end of the time step, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. @@ -592,11 +587,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! End of wide-sized variables. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt_prev, uhbt_prev, ubt_sum_prev, uhbt_sum_prev, ubt_wtd_prev ! for OBC + ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + uhbt_prev, uhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - - real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. + vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + vhbt_prev, vhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -612,9 +608,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dgeo_de ! The constant of proportionality between geopotential and ! sea surface height. It is a nondimensional number of ! order 1. For stability, this may be made larger - ! than physical problem would suggest. - real :: Instep ! The inverse of the number of barotropic time steps - ! to take. + ! than the physical problem would suggest. + real :: Instep ! The inverse of the number of barotropic time steps to take. real :: wt_end ! The weighting of the final value of eta_PF [nondim] integer :: nstep ! The number of barotropic time steps to take. type(time_type) :: & @@ -649,7 +644,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans real :: I_sum_wt_vel, I_sum_wt_eta, I_sum_wt_accel, I_sum_wt_trans real :: dt_filt ! The half-width of the barotropic filter [T ~> s]. - real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans integer :: nfilter logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open @@ -911,7 +906,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0 - Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(I,j) = 0.0 + Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo ! Copy input arrays into their wide-halo counterparts. @@ -1065,11 +1060,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J)) enddo ; enddo else !$OMP parallel do default(shared) @@ -1328,15 +1323,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,nz,av_rem_u,av_rem_v,CS,visc_rem_u, & -!$OMP visc_rem_v,bt_rem_u,G,GV,nstep,bt_rem_v,Instep, & -!$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & -!$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& -!$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & -!$OMP Rayleigh_u, Rayleigh_v, & -!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & -!$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,v_max_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1406,7 +1393,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_wtd(i,j) = 0.0 enddo ; enddo - endif + endif !$OMP do do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 @@ -1417,7 +1404,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 - vbt_wtd(i,J) = 0.0 ; vbt_trans(I,j) = 0.0 + vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 enddo ; enddo ! Set the mass source, after first initializing the halos to 0. @@ -1427,19 +1414,17 @@ 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 ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that - ! can be transported out of the cell by velocities with a CFL number of - ! CFL_cor. + ! can be transported out of the cell by velocities with a CFL number of CFL_cor. u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) eta_cor_max = dt * (CS%IareaT(i,j) * & - (((find_uhbt(u_max_cor, BTCL_u(I,j), US) + uhbt0(I,j)) - & - (find_uhbt(-u_max_cor, BTCL_u(I-1,j), US) + uhbt0(I-1,j))) + & - ((find_vhbt(v_max_cor, BTCL_v(i,J), US) + vhbt0(i,J)) - & - (find_vhbt(-v_max_cor, BTCL_v(i,J-1), US) + vhbt0(i,J-1))) )) + (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & + (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & + ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & + (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else - ! Limit the sink (inward) correction to the amount of mass that is already - ! inside the cell. + ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. Htot = eta(i,j) if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) @@ -1682,11 +1667,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP 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) + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo !GOMP 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) + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 @@ -1751,9 +1736,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt !GOMP 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) + 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) enddo ; enddo endif @@ -1798,17 +1783,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo if (use_BT_cont) then !GOMP 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) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -1865,7 +1850,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP 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) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1873,10 +1858,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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. + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP 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) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else @@ -1924,7 +1909,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP 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) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1935,7 +1920,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP 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) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif @@ -1983,16 +1968,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo if (use_BT_cont) then !GOMP 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) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -2009,6 +1994,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif !GOMP end parallel + if (CS%debug_bt) then + write(mesg,'("BT vel update ",I4)') n + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, haloshift=iev-ie) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + endif + + !GOMP parallel default(shared) if (find_PF) then !GOMP do @@ -2091,6 +2094,7 @@ 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) do j=jsv,jev ; do i=isv,iev eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & @@ -2273,22 +2277,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate diagnostic quantities. if (query_averaging_enabled(CS%diag)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo - if (use_BT_cont) then - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = find_uhbt(ubt_wtd(I,j), BTCL_u(I,j), US) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = find_vhbt(vbt_wtd(i,J), BTCL_v(i,J), US) + vhbt0(i,J) - enddo ; enddo - else - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = ubt_wtd(I,j) * Datu(I,j) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = vbt_wtd(i,J) * Datv(i,J) + vhbt0(i,J) - enddo ; enddo + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo endif ! Offer various barotropic terms for averaging. @@ -2364,12 +2355,69 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + endif if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + endif + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + endif endif else if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) @@ -2615,7 +2663,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then if (use_BT_cont) then - uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) endif @@ -2633,7 +2681,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal @@ -2649,7 +2697,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal @@ -2667,7 +2715,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif @@ -3159,12 +3207,11 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) end subroutine btcalc !> The function find_uhbt determines the zonal transport for a given velocity. -function find_uhbt(u, BTC, US) result(uhbt) +function find_uhbt(u, BTC) result(uhbt) 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 :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] @@ -3302,12 +3349,11 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt !> The function find_vhbt determines the meridional transport for a given velocity. -function find_vhbt(v, BTC, US) result(vhbt) +function find_vhbt(v, BTC) result(vhbt) 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 :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] if (v == 0.0) then @@ -3324,7 +3370,7 @@ function find_vhbt(v, BTC, US) result(vhbt) end function find_vhbt -!> The function find_vhbt determines the meridional transport for a given velocity. +!> The function find_dvhbt_dv determines the marginal meridional face area 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 @@ -3839,8 +3885,6 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) real :: d_eta ! The difference between estimates of the total ! thicknesses [H ~> m or kg m-2]. integer :: is, ie, js, je, nz, i, j, k - real, parameter :: frac_cor = 0.25 - real, parameter :: slow_rate = 0.125 if (.not.associated(CS)) call MOM_error(FATAL, "bt_mass_source: "// & "Module MOM_barotropic must be initialized before it is used.") @@ -3982,7 +4026,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "BT_cont_type variables to set limits determined by "//& "MAXCFL_BT_CONT on the CFL number of the velocities "//& "that are likely to be driven by the corrective mass fluxes.", & - default=.true.) !, do_not_log=.not.CS%bound_BT_corr) + default=.true., do_not_log=.not.CS%bound_BT_corr) call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & "If true, adjust the curve fit to the BT_cont type "//& "that is used by the barotropic solver to match the "//& @@ -4021,24 +4065,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe "//& - "effective face areas from the summed continuity solver "//& - "as a function the barotropic flow in coupling between "//& - "the barotropic and baroclinic flow. This is only used "//& - "if SPLIT is true. \n", default=.true.) - call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", & - CS%Nonlinear_continuity, & + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& + "if SPLIT is true.", default=.true.) + call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& - "USE_BT_CONT_TYPE is true.", default=.false.) - CS%Nonlin_cont_update_period = 1 - if (CS%Nonlinear_continuity) & - call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", & - CS%Nonlin_cont_update_period, & + "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_BT_cont_type) + call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", CS%Nonlin_cont_update_period, & "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& "of barotropic time steps between updates to the face "//& - "areas, or 0 to update only before the barotropic stepping.",& - units="nondim", default=1) + "areas, or 0 to update only before the barotropic stepping.", & + units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& "out the velocity tendency by 1+BEBT when calculating the "//& @@ -4055,22 +4096,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& "shelf, for instance.", default=.false.) - if (CS%dynamic_psurf) then - call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & + call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & "The length scale at which the Rayleigh damping rate due "//& "to the ice strength should be the same as if a Laplacian "//& "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & - units="m", default=1.0e4, scale=US%m_to_L) - call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & - "The minimum depth to use in limiting the size of the "//& - "dynamic surface pressure for stability, if "//& - "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z) - call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & + units="m", default=1.0e4, scale=US%m_to_L, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& + "DYNAMIC_SURFACE_PRESSURE is true..", & + units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "The constant that scales the dynamic surface pressure, "//& "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& - "are < ~1.0.", units="nondim", default=0.9) - endif + "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.CS%dynamic_psurf) + 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) @@ -4295,7 +4335,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - CS%IdyCv(I,j) = G%IdyCv(I,j) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) enddo ; enddo call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) @@ -4385,7 +4425,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) - ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and + ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. if (GV%Boussinesq) then @@ -4488,6 +4528,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, & + ! 'BTCont type ratio of near east and west face areas', 'nondim') CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & @@ -4500,6 +4543,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far north velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, Time, & 'BTCont type far south velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, & + ! 'BTCont type ratio of near north and south face areas', 'nondim') + ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, & + ! 'BTCont type maximum ratios of near face areas around cells', 'nondim') endif CS%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, Time, & 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) @@ -4523,20 +4571,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif - if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(I,j) ; enddo ; enddo + if (CS%gradual_BT_ICs) then + if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & + .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo + elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then + vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo + endif endif - ! Calculate other constants which are used for btstep. if (.not.CS%nonlin_stress) then @@ -4551,7 +4600,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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 + else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -4567,21 +4616,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo endif - if (.NOT.query_initialized(CS%uhbt_IC,"uhbt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vhbt_IC,"vhbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = CS%ubtav(I,j) * Datu(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = CS%vbtav(i,J) * Datv(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart * US%m_to_L_restart * GV%m_to_H_restart /= 0.0) .and. & - ((US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) /= & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart))) then - uH_rescale = (US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) / & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart) - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = uH_rescale * CS%uhbt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = uH_rescale * CS%vhbt_IC(I,j) ; enddo ; enddo - endif - - call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) - call create_group_pass(pass_bt_hbt_btav, CS%uhbt_IC, CS%vhbt_IC, G%Domain) + if (CS%gradual_BT_ICs) & + call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) call do_group_pass(pass_bt_hbt_btav, G%Domain) @@ -4649,7 +4685,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) ! Local variables type(vardesc) :: vd(3) - real :: slow_rate + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed @@ -4662,12 +4698,20 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) endif allocate(CS) + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& + "sum(u dh_dt) while also correcting for truncation errors.", & + default=.false., do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 - ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 - ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 - ALLOC_(CS%uhbt_IC(IsdB:IedB,jsd:jed)) ; CS%uhbt_IC(:,:) = 0.0 - ALLOC_(CS%vhbt_IC(isd:ied,JsdB:JedB)) ; CS%vhbt_IC(:,:) = 0.0 + if (CS%gradual_BT_ICs) then + ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 + ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + endif vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & hor_grid='u', z_grid='1') @@ -4675,30 +4719,16 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='v', z_grid='1') 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", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vbt_IC", "m s-1", & - longname="Next initial condition for the barotropic meridional velocity",& - hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) - - if (GV%Boussinesq) then - vd(2) = var_desc("uhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic zonal transport", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic meridional transport",& - hor_grid='v', z_grid='1') - else - vd(2) = var_desc("uhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic zonal transport", & + if (CS%gradual_BT_ICs) then + vd(2) = var_desc("ubt_IC", "m s-1", & + longname="Next initial condition for the barotropic zonal velocity", & hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic meridional transport",& + vd(3) = var_desc("vbt_IC", "m s-1", & + longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) endif - 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") From 14d63487c43f8fba017a2f330a1b9c6b77e32d5e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 10:13:10 -0400 Subject: [PATCH 161/256] +Add the new parameter INTEGRAL_BT_CONTINUITY Add the new runtime parameter INTEGRAL_BT_CONTINUITY which enables the use of the time-integrated barotropic velocity to determine the cumulative transport since the start of the barotropic stepping. This new option works in all of the MOM6-examples test cases with a SPLIT=True and USE_BT_CONT_TYPE=True. By default all answers are bitwise identical, but there are changes to the entries in the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 226 ++++++++++++++++++++++++++++++++---- 1 file changed, 206 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4e4233bc38..458599aed5 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -186,6 +186,11 @@ module MOM_barotropic !! otherwise the Arakawa & Hsu scheme is used. If !! the deformation radius is not resolved Sadourny's !! scheme should probably be used. + logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps + !! to determine the integrated transports used to update the continuity + !! equation. Otherwise the transports are the sum of the transports + !! based on ]a series of instantaneous velocities and the BT_CONT_TYPE + !! for transports. This is only valid if a BT_CONT_TYPE is used. logical :: Nonlinear_continuity !< If true, the barotropic continuity equation !! uses the full ocean thickness for transport. integer :: Nonlin_cont_update_period !< The number of barotropic time steps @@ -504,7 +509,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. azon, bzon, & ! _zon & _mer are the values of the Coriolis force which @@ -537,7 +544,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. @@ -562,6 +571,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIW_(CS),SZJW_(CS)) :: & eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. + eta_IC, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or ! column mass anomaly) that was used to calculate the input ! pressure gradient accelerations [H ~> m or kg m-2]. @@ -588,10 +598,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - uhbt_prev, uhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - vhbt_prev, vhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. @@ -621,6 +635,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! 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 :: integral_BT_cont ! If true, update the continuity directly from the initial + ! condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -639,6 +655,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 :: Idt2 ! The inverse square of the time interval of this call [T-2 ~> s-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] 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 @@ -669,10 +687,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, h_neglect = GV%H_subroundoff Idt = 1.0 / dt + Idt2 = Idt**2 accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont + interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -736,6 +757,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) dtbt = dt * Instep + Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 @@ -779,6 +801,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, else call create_group_pass(CS%pass_eta_bt_rem, eta_PF, CS%BT_Domain) endif + if (integral_BT_cont) & + call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) ! The following halo updates are not needed without wide halos. RWH ! We do need them after all. @@ -799,6 +823,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This might only be needed with OBCs. + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -892,6 +921,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then eta_PF_1(i,j) = 0.0 ; d_eta_PF(i,j) = 0.0 endif + if (integral_BT_cont) then + eta_IC(i,j) = 0.0 + endif p_surf_dyn(i,j) = 0.0 if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 enddo ; enddo @@ -924,6 +956,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_PF(i,j) = eta_PF_in(i,j) enddo ; enddo endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + eta_IC(i,j) = eta_in(i,j) + enddo ; enddo + endif !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -1094,10 +1132,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 enddo ; enddo !$OMP parallel do default(shared) do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie @@ -1662,9 +1702,36 @@ 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 + if (integral_BT_cont) then + !GOMP parallel do default(shared) + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) + enddo ; enddo + !GOMP parallel do default(shared) + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) + enddo ; enddo + endif + !GOMP parallel default(shared) if (CS%dynamic_psurf .or. .not.project_velocity) then - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + enddo ; enddo + !GOMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + enddo ; enddo + !GOMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + enddo ; enddo + elseif (use_BT_cont) then !GOMP 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)) + uhbt0(I,j) @@ -1739,6 +1806,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) + !Avoid this? ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) enddo ; enddo endif @@ -1747,6 +1815,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) + !Avoid this? vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) enddo ; enddo endif endif @@ -1790,7 +1859,16 @@ 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 + if (integral_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv-1,iev+1 + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + ! I do not know whether this is accurate enough. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP 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)) + vhbt0(i,J) @@ -1847,7 +1925,16 @@ 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 + if (integral_BT_cont) then + !GOMP do + do j=jsv,jev ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + ! I do not know whether this is accurate enough. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) @@ -1906,7 +1993,16 @@ 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 + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + ! I do not know whether this is accurate enough. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP 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)) + uhbt0(I,j) @@ -1974,7 +2070,16 @@ 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 - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv,iev + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + ! I do not know whether this is accurate enough. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) @@ -2009,6 +2114,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, scale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_to_m**2*GV%H_to_m) endif @@ -2037,12 +2145,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP 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) + !This already happened: ubt_int(I,j) = ubt_int(I,j) + dtbt * 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 do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + !This already happened: vbt_int(i,J) = vbt_int(i,J) + dtbt * 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 @@ -2076,14 +2186,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * 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) + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) endif enddo ; enddo ; endif @@ -2092,15 +2206,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) endif - !$OMP parallel do default(shared) - 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) - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + else + !$OMP parallel do default(shared) + 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) + enddo ; enddo + endif if (do_hifreq_output) then time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) @@ -3229,6 +3355,33 @@ function find_uhbt(u, BTC) result(uhbt) end function find_uhbt + +!> The function find_uhbt_int determines the time-integrated zonal transport for a given +!! time-integrated velocity. +function find_uhbt_int(u_int, BTC, dt_bc, Idt2) result(uhbt_int) + real, intent(in) :: u_int !< The local time-integrated zonal velocity [L ~> m] + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. + real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + + real :: uhbt_int !< The time integrated zonal barotropic transport [L2 H ~> m3] + + if (u_int == 0.0) then + uhbt_int = 0.0 + elseif (u_int < BTC%uBT_EE*dt_bc) then + uhbt_int = (u_int - BTC%uBT_EE*dt_bc) * BTC%FA_u_EE + BTC%uh_EE*dt_bc + elseif (u_int < 0.0) then + uhbt_int = u_int * (BTC%FA_u_E0 + BTC%uh_crvE*Idt2 * u_int**2) + elseif (u_int <= BTC%uBT_WW*dt_bc) then + uhbt_int = u_int * (BTC%FA_u_W0 + BTC%uh_crvW*Idt2 * u_int**2) + else ! (u_int > BTC%uBT_WW*dt_bc) + uhbt_int = (u_int - BTC%uBT_WW*dt_bc) * BTC%FA_u_WW + BTC%uh_WW*dt_bc + endif + +end function find_uhbt_int + !> 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] @@ -3370,6 +3523,31 @@ function find_vhbt(v, BTC) result(vhbt) end function find_vhbt +!> The function find_vhbt_int determines the time-integrated meridional transport for a given +!! time-integrated velocity. +function find_vhbt_int(v_int, BTC, dt_bc, Idt2) result(vhbt_int) + real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. + real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + real :: vhbt_int !< The time integrated meridional barotropic transport [L2 H ~> m3] + + if (v_int == 0.0) then + vhbt_int = 0.0 + elseif (v_int < BTC%vBT_NN*dt_bc) then + vhbt_int = (v_int - BTC%vBT_NN*dt_bc) * BTC%FA_v_NN + BTC%vh_NN*dt_bc + elseif (v_int < 0.0) then + vhbt_int = v_int * (BTC%FA_v_N0 + BTC%vh_crvN*Idt2 * v_int**2) + elseif (v_int <= BTC%vBT_SS*dt_bc) then + vhbt_int = v_int * (BTC%FA_v_S0 + BTC%vh_crvS*Idt2 * v_int**2) + else ! (v_int > BTC%vBT_SS*dt_bc) + vhbt_int = (v_int - BTC%vBT_SS*dt_bc) * BTC%FA_v_SS + BTC%vh_SS*dt_bc + endif + +end function find_vhbt_int + !> The function find_dvhbt_dv determines the marginal meridional face area 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] @@ -4017,6 +4195,19 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "Use the split time stepping if true.", default=.true.) if (.not.CS%split) return + call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& + "if SPLIT is true.", default=.true.) + call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", CS%integral_bt_cont, & + "If true, use the time-integrated velocity over the barotropic steps "//& + "to determine the integrated transports used to update the continuity "//& + "equation. Otherwise the transports are the sum of the transports based on "//& + "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//& + "This is only valid if USE_BT_CONT_TYPE = True.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & "If true, the corrective pseudo mass-fluxes into the "//& "barotropic solver are limited to values that require "//& @@ -4030,7 +4221,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & "If true, adjust the curve fit to the BT_cont type "//& "that is used by the barotropic solver to match the "//& - "transport about which the flow is being linearized.", default=.false.) + "transport about which the flow is being linearized.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & "If true, adjust the initial conditions for the "//& "barotropic solver to the values from the layered "//& @@ -4064,12 +4256,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The barotropic y-halo size that is actually used.", & layoutParam=.true.) - call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe "//& - "effective face areas from the summed continuity solver "//& - "as a function the barotropic flow in coupling between "//& - "the barotropic and baroclinic flow. This is only used "//& - "if SPLIT is true.", default=.true.) call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& From 6374aaf77a8edcae4e310c1c95bf21aa84a4ecd6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 12:32:28 -0400 Subject: [PATCH 162/256] +Add find_duhbt_dubt_int Added the new subroutines find_duhbt_dubt_int and find_dvhbt_dvbt_int, and use the time-integrated forms to set the inverse face area, the transport correction for consistency between the transport from the initial barotropic velocity and the summed layer transports, and the maximum corrective mass source when INTEGRAL_BT_CONT=True. Also only log BT_CONT_CORR_BOUNDS when BOUND_BT_CORR is set to true. By default, all answers are bitwise identical, but there are minor changes to the entries in the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 120 +++++++++++++++++++++++++++++------- 1 file changed, 99 insertions(+), 21 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 458599aed5..f136f3ef2c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -650,6 +650,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing ! squared [H L-2 ~> m-1 or kg m-4]. real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1]. + real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m]. 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]. @@ -1080,22 +1081,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k) enddo ; enddo ; enddo endif - if (use_BT_cont) then - if (CS%adjust_BT_cont) then - ! Use the additional input transports to broaden the fits - ! over which the bt_cont_type applies. - - ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. - 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) - call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) - call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) - if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) - if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - - call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) - endif + if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then + ! Use the additional input transports to broaden the fits + ! over which the bt_cont_type applies. + + ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. + 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) + call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) + call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, 1+ievf-ie) + endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt_int(dt*ubt(I,j), BTCL_u(I,j), dt, Idt2) * Idt + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt_int(dt*vbt(i,J), BTCL_v(i,J), dt, Idt2) * Idt + enddo ; enddo + elseif (use_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) @@ -1177,6 +1187,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 + elseif (integral_BT_cont) then + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du_int(ubt(I,j)*dt, BTCL_u(I,j), US, dt, Idt2), & + CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & CS%dy_Cu(I,j)*Htot_avg) ) @@ -1200,6 +1213,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 + elseif (integral_BT_cont) then + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv_int(vbt(i,J)*dt, BTCL_v(i,J), US, dt, Idt2), & + CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & CS%dx_Cv(i,J)*Htot_avg) ) @@ -1363,7 +1379,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - !$OMP parallel default(shared) private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1450,18 +1466,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the mass source, after first initializing the halos to 0. !$OMP do do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo - if (CS%bound_BT_corr) then ; if (use_BT_Cont .and. CS%BT_cont_bounds) then + if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that ! can be transported out of the cell by velocities with a CFL number of CFL_cor. - u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) - v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) - eta_cor_max = dt * (CS%IareaT(i,j) * & + if (integral_BT_cont) then + uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont + vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont + eta_cor_max = (CS%IareaT(i,j) * & + (((find_uhbt_int(uint_cor, BTCL_u(I,j), dt, Idt2) + dt*uhbt0(I,j)) - & + (find_uhbt_int(-uint_cor, BTCL_u(I-1,j), dt, Idt2) + dt*uhbt0(I-1,j))) + & + ((find_vhbt_int(vint_cor, BTCL_v(i,J), dt, Idt2) + dt*vhbt0(i,J)) - & + (find_vhbt_int(-vint_cor, BTCL_v(i,J-1), dt, Idt2) + dt*vhbt0(i,J-1))) )) + else ! (use_BT_Cont) then + u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) + v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + eta_cor_max = dt * (CS%IareaT(i,j) * & (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) + endif CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. @@ -3406,6 +3432,32 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du +!> The function find_duhbt_du_int determines the marginal zonal face area for a given +!! time-integrated velocity. +function find_duhbt_du_int(u_int, BTC, US, dt_bc, Idt2) result(duhbt_du) + real, intent(in) :: u_int !< The local zonal time-integrated velocity [L ~> m] + 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + + real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] + + if (u_int == 0.0) then + duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. + elseif (u_int < BTC%uBT_EE*dt_bc) then + duhbt_du = BTC%FA_u_EE + elseif (u_int < 0.0) then + duhbt_du = (BTC%FA_u_E0 + 3.0*(BTC%uh_crvE*Idt2) * u_int**2) + elseif (u_int <= BTC%uBT_WW*dt_bc) then + duhbt_du = (BTC%FA_u_W0 + 3.0*(BTC%uh_crvW*Idt2) * u_int**2) + else ! (u_int > BTC%uBT_WW*dt_bc) + duhbt_du = BTC%FA_u_WW + endif + +end function find_duhbt_du_int !> This function inverts the transport function to determine the barotopic !! velocity that is consistent with a given transport. @@ -3571,6 +3623,32 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv +!> The function find_dvhbt_dv_int determines the marginal meridional face area for a given +!! time-integrated velocity. +function find_dvhbt_dv_int(v_int, BTC, US, dt_bc, Idt2) result(dvhbt_dv) + real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] + 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] + + if (v_int == 0.0) then + dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. + elseif (v_int < BTC%vBT_NN*dt_bc) then + dvhbt_dv = BTC%FA_v_NN + elseif (v_int < 0.0) then + dvhbt_dv = BTC%FA_v_N0 + 3.0*(BTC%vh_crvN*Idt2) * v_int**2 + elseif (v_int <= BTC%vBT_SS*dt_bc) then + dvhbt_dv = BTC%FA_v_S0 + 3.0*(BTC%vh_crvS*Idt2) * v_int**2 + else ! (v_int > BTC%vBT_SS*dt_bc) + dvhbt_dv = BTC%FA_v_SS + endif + +end function find_dvhbt_dv_int + !> 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) From 4743f8cec6fc0c73bf0745f7469965a26f11d201 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 18:53:00 -0400 Subject: [PATCH 163/256] +Implemented integral_BT_cont options for OBCs Added code to implement new integral_BT_cont options within the barotropic open boundary condition code. A number of new arguments were added to apply_velocity_OBCS. In addition, the handling of updates to ubt_sum, uhbt_sum and ubt_wtd with open boundary conditions were simplified. There are minor answer changes if INTEGRAL_BT_CONTINUITY=True, but all answers in the existing MOM6-examples tess cases are bitwise identical. --- src/core/MOM_barotropic.F90 | 98 +++++++++++++++++++++++-------------- 1 file changed, 60 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f136f3ef2c..f5e3fad882 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -635,8 +635,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! 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 :: integral_BT_cont ! If true, update the continuity directly from the initial - ! condition using the time-integrated barotropic velocity. + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -2185,46 +2185,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP 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) - 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) - ubt_wtd(I,j) = ubt_wtd_prev(I,j) - endif - enddo ; enddo - endif - - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP 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) - vbt_wtd(i,J) = vbt_wtd_prev(i,J) - endif - enddo ; enddo - endif 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) + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, dt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + 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) + ! Update the summed and integrated quantities from the saved previous values. + ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + ubt_wtd(I,j) = ubt_wtd_prev(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) + ! Update the summed and integrated quantities from the saved previous values. + vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) endif enddo ; enddo ; endif endif @@ -2706,8 +2691,9 @@ end subroutine set_dtbt !! velocities and mass transports, as developed by Mehmet Ilicak. subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, Datu, Datv, & - BTCL_u, BTCL_v, uhbt0, vhbt0) + G, MS, US, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, & + dt_elapsed, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, & + uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int_prev, vhbt_int_prev) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of @@ -2739,6 +2725,13 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2757,6 +2750,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! the barotropic functions agree with the sum !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -2767,14 +2768,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] - real :: h_in + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy + real :: Idt2 ! The inverse square of the baroclinic time interval [T-2 ~> s-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad real, parameter :: eps = 1.0e-20 is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + + Idtbt = 1.0 / dtbt + Idt2 = (1.0 / dt_baroclinic)**2 + 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 if (OBC%segment(OBC%segnum_u(I,j))%specified) then @@ -2814,7 +2824,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then + !Need: ubt_int, uhbt_int_prev, dt, Idt2, n, Idtbt. + if (integral_BT_cont) then + uhbt_int_new = find_uhbt_int(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j), dt_baroclinic, Idt2) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + elseif (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) @@ -2866,10 +2881,15 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) + !Need: vbt_int, vhbt_int_prev. + if (integral_BT_cont) then + vhbt_int_new = find_vhbt_int(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J), dt_baroclinic, Idt2) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else - vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) + vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif endif @@ -3873,8 +3893,10 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain end subroutine set_local_BT_cont_types -!> Adjust_local_BT_cont_types sets up reordered versions of the BT_cont type -!! in the local_BT_cont types, which have wide halos properly filled in. +!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve +!! translating velocities into transports to match the inital values of velocities and +!! summed transports when the velocities are larger than the first guesses of the cubic +!! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & G, US, MS, halo) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. From 2a73d7dafe251e65e5a33b5533697b4342d94b52 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 14 Jul 2020 15:26:10 -0800 Subject: [PATCH 164/256] +Adding a halo update for tracer reservoirs. --- src/core/MOM_open_boundary.F90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c0e64db491..31f037c66e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1590,7 +1590,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) ! Local variables real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in ! a restart file to the internal representation in this run. - integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: i, j, k, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1603,6 +1603,11 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & To_All+Scalar_Pair) if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) + if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) + enddo + endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to @@ -4711,7 +4716,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif ! Still painfully inefficient, now in four dimensions. - if (any(OBC%tracer_x_reservoirs_used)) then + ! Allocating both for now so that the pass_vector works. + if (any(OBC%tracer_x_reservoirs_used) .or. any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr @@ -4727,8 +4733,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif endif enddo - endif - if (any(OBC%tracer_y_reservoirs_used)) then +! endif +! if (any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr From 37a7ee0da1bd0860debe98b4a7110958dc7f4b88 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jul 2020 12:57:24 -0400 Subject: [PATCH 165/256] +Reuse find_uhbt with INTEGRAL_BT_CONT Revised the dimensions of the entries in the local_BT_Cont types when INTEGRAL_BT_CONT=True for efficiency and to enable find_uhbt and other routines to be used regardless of the value of INTEGRAL_BT_CONT. Some arguments that are no longer needed have been removed from some subroutines. All answers are bitwise identical in the MOM6-examples test suite, but changes to the order of arithmetic leads to changes from the previous version when INTEGRAL_BT_CONT=True, and the rescaling is controlled via new optional arguments to internal routines. --- src/core/MOM_barotropic.F90 | 452 ++++++++++++++++-------------------- 1 file changed, 196 insertions(+), 256 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f5e3fad882..9e62e84f3b 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -327,14 +327,20 @@ module MOM_barotropic !! drawing from nearby to the west [H L ~> m2 or kg m-1]. real :: FA_u_WW !< The effective open face area for zonal barotropic transport !! drawing from locations far to the west [H L ~> m2 or kg m-1]. - real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_WW. uBT_WW must be non-negative. - real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_EE. uBT_EE must be non-positive. - real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3]. - 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]. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_u_type !> A desciption of the functional dependence of transport at a v-point @@ -347,14 +353,20 @@ module MOM_barotropic !! drawing from nearby to the south [H L ~> m2 or kg m-1]. real :: FA_v_SS !< The effective open face area for meridional barotropic transport !! drawing from locations far to the south [H L ~> m2 or kg m-1]. - real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_SS. vBT_SS must be non-negative. - real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_NN. vBT_NN must be non-positive. - real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_v_type !> A container for passing around active tracer point memory limits @@ -656,7 +668,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 :: Idt2 ! The inverse square of the time interval of this call [T-2 ~> s-2]. real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 @@ -688,14 +699,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, h_neglect = GV%H_subroundoff Idt = 1.0 / dt - Idt2 = Idt**2 accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont - interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -826,8 +835,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) if (integral_BT_cont) then call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) - ! This might only be needed with OBCs. - call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (apply_OBC_open) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) @@ -1035,7 +1045,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate the open areas at the velocity points. ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor. - if (use_BT_cont) then + if (integral_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie, dt_baroclinic=dt) + elseif (use_BT_cont) then call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie) else if (CS%Nonlinear_continuity) then @@ -1048,7 +1060,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif ! Determine the difference between the sum of the layer fluxes and the @@ -1093,17 +1105,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) + if (integral_BT_cont) then + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie, dt_baroclinic=dt) + else + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie) + endif endif if (integral_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt_int(dt*ubt(I,j), BTCL_u(I,j), dt, Idt2) * Idt + uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt_int(dt*vbt(i,J), BTCL_v(i,J), dt, Idt2) * Idt + vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt enddo ; enddo elseif (use_BT_cont) then !$OMP parallel do default(shared) @@ -1188,10 +1205,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du_int(ubt(I,j)*dt, BTCL_u(I,j), US, dt, Idt2), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else CS%IDatu(I,j) = 1.0 / Htot_avg @@ -1214,10 +1231,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv_int(vbt(i,J)*dt, BTCL_v(i,J), US, dt, Idt2), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else CS%IDatv(i,J) = 1.0 / Htot_avg @@ -1475,10 +1492,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont eta_cor_max = (CS%IareaT(i,j) * & - (((find_uhbt_int(uint_cor, BTCL_u(I,j), dt, Idt2) + dt*uhbt0(I,j)) - & - (find_uhbt_int(-uint_cor, BTCL_u(I-1,j), dt, Idt2) + dt*uhbt0(I-1,j))) + & - ((find_vhbt_int(vint_cor, BTCL_v(i,J), dt, Idt2) + dt*vhbt0(i,J)) - & - (find_vhbt_int(-vint_cor, BTCL_v(i,J-1), dt, Idt2) + dt*vhbt0(i,J-1))) )) + (((find_uhbt(uint_cor, BTCL_u(I,j)) + dt*uhbt0(I,j)) - & + (find_uhbt(-uint_cor, BTCL_u(I-1,j)) + dt*uhbt0(I-1,j))) + & + ((find_vhbt(vint_cor, BTCL_v(i,J)) + dt*vhbt0(i,J)) - & + (find_vhbt(-vint_cor, BTCL_v(i,J-1)) + dt*vhbt0(i,J-1))) )) else ! (use_BT_Cont) then u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) @@ -1744,13 +1761,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (integral_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) enddo ; enddo !GOMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) enddo ; enddo !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 @@ -1832,7 +1847,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) - !Avoid this? ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) enddo ; enddo endif @@ -1841,7 +1855,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) - !Avoid this? vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) enddo ; enddo endif endif @@ -1889,9 +1902,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) - ! I do not know whether this is accurate enough. + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -1955,9 +1967,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=jsv,jev ; do I=isv-1,iev ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) - ! I do not know whether this is accurate enough. + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2023,9 +2034,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) - ! I do not know whether this is accurate enough. + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2100,9 +2110,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do J=jsv-1,jev ; do i=isv,iev vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) - ! I do not know whether this is accurate enough. + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2171,14 +2180,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP 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) - !This already happened: ubt_int(I,j) = ubt_int(I,j) + dtbt * 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 do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - !This already happened: vbt_int(i,J) = vbt_int(i,J) + dtbt * 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 @@ -2187,10 +2194,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (apply_OBCs) then 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, integral_BT_cont, & - n*dtbt, dt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & - ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) 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 @@ -2689,11 +2696,10 @@ end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & - eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, & - dt_elapsed, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, & - uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int_prev, vhbt_int_prev) +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & + ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & + use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & + BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of @@ -2730,8 +2736,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! using the time-integrated barotropic velocity. real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping !! that will have elapsed [T ~> s]. - real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of - !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2751,12 +2755,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic - !! velocity [L T-1 ~> m s-1]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic - !! velocity [L T-1 ~> m s-1]. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables @@ -2773,7 +2777,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy - real :: Idt2 ! The inverse square of the baroclinic time interval [T-2 ~> s-2]. real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad @@ -2783,7 +2786,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return Idtbt = 1.0 / dtbt - Idt2 = (1.0 / dt_baroclinic)**2 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 @@ -2824,11 +2826,10 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - !Need: ubt_int, uhbt_int_prev, dt, Idt2, n, Idtbt. if (integral_BT_cont) then - uhbt_int_new = find_uhbt_int(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j), dt_baroclinic, Idt2) + & - dt_elapsed*uhbt0(I,j) - uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt elseif (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else @@ -2881,11 +2882,10 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - !Need: vbt_int, vhbt_int_prev. if (integral_BT_cont) then - vhbt_int_new = find_vhbt_int(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J), dt_baroclinic, Idt2) + & - dt_elapsed*vhbt0(i,J) - vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt elseif (use_BT_cont) then vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else @@ -2901,7 +2901,8 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v) +subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. @@ -2917,6 +2918,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2929,18 +2935,19 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B !! v-points. ! Local variables + real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw + I_dt = 1.0 / dt_baroclinic if ((isdw < isd) .or. (jsdw < jsd)) then call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& @@ -2984,8 +2991,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j), US) + if (integral_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt + elseif (use_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j)) else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif @@ -3036,8 +3045,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J), US) + if (integral_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt + elseif (use_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J)) else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif @@ -3378,14 +3389,17 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) end subroutine btcalc -!> The function find_uhbt determines the zonal transport for a given velocity. +!> The function find_uhbt determines the zonal transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given +!! time-integrated velocity. function find_uhbt(u, BTC) result(uhbt) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. - real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] + real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (u == 0.0) then uhbt = 0.0 @@ -3401,41 +3415,14 @@ function find_uhbt(u, BTC) result(uhbt) end function find_uhbt - -!> The function find_uhbt_int determines the time-integrated zonal transport for a given -!! time-integrated velocity. -function find_uhbt_int(u_int, BTC, dt_bc, Idt2) result(uhbt_int) - real, intent(in) :: u_int !< The local time-integrated zonal velocity [L ~> m] - type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that - !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - - real :: uhbt_int !< The time integrated zonal barotropic transport [L2 H ~> m3] - - if (u_int == 0.0) then - uhbt_int = 0.0 - elseif (u_int < BTC%uBT_EE*dt_bc) then - uhbt_int = (u_int - BTC%uBT_EE*dt_bc) * BTC%FA_u_EE + BTC%uh_EE*dt_bc - elseif (u_int < 0.0) then - uhbt_int = u_int * (BTC%FA_u_E0 + BTC%uh_crvE*Idt2 * u_int**2) - elseif (u_int <= BTC%uBT_WW*dt_bc) then - uhbt_int = u_int * (BTC%FA_u_W0 + BTC%uh_crvW*Idt2 * u_int**2) - else ! (u_int > BTC%uBT_WW*dt_bc) - uhbt_int = (u_int - BTC%uBT_WW*dt_bc) * BTC%FA_u_WW + BTC%uh_WW*dt_bc - endif - -end function find_uhbt_int - -!> 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] +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_duhbt_du(u, BTC) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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 - + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] if (u == 0.0) then @@ -3452,51 +3439,30 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du -!> The function find_duhbt_du_int determines the marginal zonal face area for a given -!! time-integrated velocity. -function find_duhbt_du_int(u_int, BTC, US, dt_bc, Idt2) result(duhbt_du) - real, intent(in) :: u_int !< The local zonal time-integrated velocity [L ~> m] - 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - - real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] - - if (u_int == 0.0) then - duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. - elseif (u_int < BTC%uBT_EE*dt_bc) then - duhbt_du = BTC%FA_u_EE - elseif (u_int < 0.0) then - duhbt_du = (BTC%FA_u_E0 + 3.0*(BTC%uh_crvE*Idt2) * u_int**2) - elseif (u_int <= BTC%uBT_WW*dt_bc) then - duhbt_du = (BTC%FA_u_W0 + 3.0*(BTC%uh_crvW*Idt2) * u_int**2) - else ! (u_int > BTC%uBT_WW*dt_bc) - duhbt_du = BTC%FA_u_WW - endif - -end function find_duhbt_du_int - !> 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) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function uhbt_to_ubt(uhbt, BTC, guess) result(ubt) real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated + !! transport [H L2 ~> m3 or kg]. 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, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1]. The result - !! is not allowed to be dramatically larger than guess. - real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]. + !! layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: ubt_min, ubt_max, uhbt_err, derr_du - real :: uherr_min, uherr_max + real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3564,7 +3530,7 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif ubt = SIGN(vsr * guess, ubt) @@ -3573,13 +3539,16 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt -!> The function find_vhbt determines the meridional transport for a given velocity. +!> The function find_vhbt determines the meridional transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given +!! time-integrated velocity. function find_vhbt(v, BTC) result(vhbt) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (v == 0.0) then vhbt = 0.0 @@ -3595,38 +3564,14 @@ function find_vhbt(v, BTC) result(vhbt) end function find_vhbt -!> The function find_vhbt_int determines the time-integrated meridional transport for a given -!! time-integrated velocity. -function find_vhbt_int(v_int, BTC, dt_bc, Idt2) result(vhbt_int) - real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_dvhbt_dv(v, BTC) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - real :: vhbt_int !< The time integrated meridional barotropic transport [L2 H ~> m3] - - if (v_int == 0.0) then - vhbt_int = 0.0 - elseif (v_int < BTC%vBT_NN*dt_bc) then - vhbt_int = (v_int - BTC%vBT_NN*dt_bc) * BTC%FA_v_NN + BTC%vh_NN*dt_bc - elseif (v_int < 0.0) then - vhbt_int = v_int * (BTC%FA_v_N0 + BTC%vh_crvN*Idt2 * v_int**2) - elseif (v_int <= BTC%vBT_SS*dt_bc) then - vhbt_int = v_int * (BTC%FA_v_S0 + BTC%vh_crvS*Idt2 * v_int**2) - else ! (v_int > BTC%vBT_SS*dt_bc) - vhbt_int = (v_int - BTC%vBT_SS*dt_bc) * BTC%FA_v_SS + BTC%vh_SS*dt_bc - endif - -end function find_vhbt_int - -!> The function find_dvhbt_dv determines the marginal meridional face area 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 + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] if (v == 0.0) then @@ -3643,50 +3588,30 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv -!> The function find_dvhbt_dv_int determines the marginal meridional face area for a given -!! time-integrated velocity. -function find_dvhbt_dv_int(v_int, BTC, US, dt_bc, Idt2) result(dvhbt_dv) - real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] - 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] - - if (v_int == 0.0) then - dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. - elseif (v_int < BTC%vBT_NN*dt_bc) then - dvhbt_dv = BTC%FA_v_NN - elseif (v_int < 0.0) then - dvhbt_dv = BTC%FA_v_N0 + 3.0*(BTC%vh_crvN*Idt2) * v_int**2 - elseif (v_int <= BTC%vBT_SS*dt_bc) then - dvhbt_dv = BTC%FA_v_S0 + 3.0*(BTC%vh_crvS*Idt2) * v_int**2 - else ! (v_int > BTC%vBT_SS*dt_bc) - dvhbt_dv = BTC%FA_v_SS - endif - -end function find_dvhbt_dv_int - !> 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) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function vhbt_to_vbt(vhbt, BTC, guess) result(vbt) real, intent(in) :: vhbt !< The barotropic meridional transport that should be - !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the + !! time-integrated transport [H L2 ~> m3 or kg]. 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, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed - !! to be dramatically larger than guess [L T-1 ~> m s-1]. - real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: vbt_min, vbt_max, vhbt_err, derr_dv - real :: vherr_min, vherr_max + real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3754,7 +3679,7 @@ function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif vbt = SIGN(guess * vsr, vbt) @@ -3765,7 +3690,7 @@ end function vhbt_to_vbt !> This subroutine sets up reordered versions of the BT_cont type in the !! local_BT_cont types, which have wide halos properly filled in. -subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo) +subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic) type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the !! barotropic solver. type(memory_size_type), intent(in) :: MS !< A type that describes the @@ -3780,16 +3705,26 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating !! the halos of wide arrays. integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step + !! [T ~> s], which is provided if + !! INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & - u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW + u_polarity, & ! An array used to test for halo update polarity [nondim] + uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1] real, dimension(SZIW_(MS),SZJBW_(MS)) :: & - v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + v_polarity, & ! An array used to test for halo update polarity [nondim] + vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & @@ -3847,7 +3782,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) - BTCL_u(I,j)%uBT_EE = uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = uBT_WW(I,j) + BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j) ! Check for reversed polarity in the tripolar halo regions. if (u_polarity(I,j) < 0.0) then call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW) @@ -3870,7 +3805,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) - BTCL_v(i,J)%vBT_NN = vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = vBT_SS(i,J) + BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J) ! Check for reversed polarity in the tripolar halo regions. if (v_polarity(i,J) < 0.0) then call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS) @@ -3898,7 +3833,7 @@ end subroutine set_local_BT_cont_types !! summed transports when the velocities are larger than the first guesses of the cubic !! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, halo) + G, US, MS, halo, dt_baroclinic) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), & intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1]. @@ -3917,73 +3852,78 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & 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) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is + !! provided if INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW real, dimension(SZIW_(MS),SZJBW_(MS)) :: & v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic !$OMP parallel do default(shared) do j=js-hs,je+hs ; do I=is-hs-1,ie+hs - if ((ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then + if ((dt*ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (dt*uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_WW = ubt(I,j) + BTCL_u(I,j)%ubt_WW = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_W0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_W0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_WW = uhbt(I,j) + BTCL_u(I,j)%uh_WW = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j)) - elseif ((ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then + elseif ((dt*ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (dt*uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_EE = ubt(I,j) + BTCL_u(I,j)%ubt_EE = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_E0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_E0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_EE = uhbt(I,j) + BTCL_u(I,j)%uh_EE = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j)) endif enddo ; enddo !$OMP parallel do default(shared) do J=js-hs-1,je+hs ; do i=is-hs,ie+hs - if ((vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then + if ((dt*vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (dt*vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_SS = vbt(i,J) + BTCL_v(i,J)%vbt_SS = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_S0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_S0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_SS = vhbt(i,J) + BTCL_v(i,J)%vh_SS = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J)) - elseif ((vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then + elseif ((dt*vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (dt*vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_NN = vbt(i,J) + BTCL_v(i,J)%vbt_NN = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_N0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_N0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_NN = vhbt(i,J) + BTCL_v(i,J)%vh_NN = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J)) endif From e218354871e481a0608f6c7b7f6189adffc6918c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jul 2020 13:47:05 -0400 Subject: [PATCH 166/256] (*?)Revised ice_shelf_driver.F90 so it compiles Revised ice_shelf_driver.F90 so that it compiles successfully and is similar to MOM_driver.F90 where possible. In addition, deleted the files MOM_surface_forcing.F90 and user_surface_forcing.F90 in the ice_solo_driver directory, as these are unused and out-of-date versions of the equivalent files in the solo_driver directory. Some of the changes are not as streamlines as they could be if the solo_ice_shelf code used its own version of diag_mediator, or if the interface to diag_mediator were revised so that some of its ocean-specific arguments are optional. There is no test-case exercising this code, but at least it now compiles, whereas it did not compile before. --- .../ice_solo_driver/MOM_surface_forcing.F90 | 1203 ----------------- .../ice_solo_driver/ice_shelf_driver.F90 | 396 +++--- .../ice_solo_driver/user_surface_forcing.F90 | 338 ----- 3 files changed, 226 insertions(+), 1711 deletions(-) delete mode 100644 config_src/ice_solo_driver/MOM_surface_forcing.F90 delete mode 100644 config_src/ice_solo_driver/user_surface_forcing.F90 diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 deleted file mode 100644 index 79bf924ca3..0000000000 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1203 +0,0 @@ -module MOM_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - May 2002 * -!* Edited by Stephen Griffies June 2014 * -!* * -!* This program contains the subroutines that calculate the * -!* surface wind stresses and fluxes of buoyancy or temperature and * -!* fresh water. These subroutines will be called every time step, * -!* even if the wind stresses or buoyancy fluxes are constant in time * -!* - in that case these routines return quickly without doing * -!* anything. In addition, any I/O of forcing fields is controlled * -!* by surface_forcing_init, located in this file. * -!* * -!* set_forcing is a small entry subroutine for the subroutines in * -!* this file. It provides the external access to these subroutines. * -!* * -!* wind_forcing determines the wind stresses and places them into * -!* taux[][] and tauy[][]. Often wind_forcing must be tailored for * -!* a particular application - either by specifying file and variable * -!* names or by providing appropriate internal expressions for the * -!* stresses. * -!* * -!* buoyancy_forcing determines the surface fluxes of buoyancy, * -!* temperature, and fresh water, as is appropriate. A restoring * -!* boundary condition is implemented, but the code for any other * -!* boundary condition will usually be modified - either to specify * -!* file and variable names and which time level to read, or to set * -!* an internal expression for the variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - -use MOM_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 -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : callTree_enter, callTree_leave -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_string_functions, only : uppercase -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher -use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing -use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS - -implicit none ; private - -#include - -public set_forcing -public surface_forcing_init -public forcing_diagnostics -public forcing_save_restart - -! surface_forcing_CS is a structure containing pointers to the forcing fields -! 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 :: 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 [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 - - ! 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 - -contains - -!> This subroutine calls other subroutines in this file to get surface forcing fields. -!! It also allocates and initializes the fields in the flux type. -subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day_start !< The start time of the fluxes - type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(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 - - ! Local variables - real :: dt ! length of time over which fluxes applied [s] - type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - call cpu_clock_begin(id_clock_forcing) - - day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) - - if (CS%first_call_set_forcing) then - ! 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.) - if (trim(CS%buoy_config) /= "NONE") then - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) - endif - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore, isd, ied, jsd, jed) - endif ! endif for CS%use_temperature - endif - endif - - ! calls to various wind options - if (CS%variable_winds .or. CS%first_call_set_forcing) then - if (trim(CS%wind_config) == "file") then - call wind_forcing_from_file(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_zero(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, CS%user_forcing_CSp) - elseif (CS%variable_winds .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable winds defined with no wind config") - else - call MOM_error(FATAL, & - "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) - endif - endif - 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, 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, 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.") -! call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "USER") then - call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) - elseif (trim(CS%buoy_config) == "NONE") then - call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") - elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable buoy defined with no buoy config.") - else - call MOM_error(FATAL, & - "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) - endif - endif - - if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) - endif - - ! Allow for user-written code to alter the fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, day_center, G, CS%urf_CS) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - if (CS%variable_winds .or. CS%first_call_set_forcing) then - call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) - endif - - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G, US) - endif - - CS%first_call_set_forcing = .false. - - call cpu_clock_end(id_clock_forcing) -end subroutine set_forcing - -!> This subroutine allocates arrays for buoyancy forcing. -subroutine buoyancy_forcing_allocate(fluxes, G, CS) - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic - !! forcing fields that will be allocated here - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - ! surface restoring fields - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%S_Restore,isd,ied,jsd,jed) - endif - - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy,isd,ied,jsd,jed) - - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore,isd,ied,jsd,jed) - - endif ! endif for CS%use_temperature - -end subroutine buoyancy_forcing_allocate - - -! This subroutine sets the surface wind stresses to zero -subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - 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 - - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_zero, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - if (CS%read_gust_2d) then - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust(i,j)/CS%Rho0) - enddo ; enddo ; endif - else - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust_const/CS%Rho0) - enddo ; enddo ; endif - endif - - call callTree_leave("wind_forcing_zero") -end subroutine wind_forcing_zero - - -!> This subroutine sets the surface wind stresses according to double gyre. -subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_2gyre") -end subroutine wind_forcing_2gyre - - -!> This subroutine sets the surface wind stresses according to single gyre. -subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_1gyre") -end subroutine wind_forcing_1gyre - - -!> This subroutine sets the surface wind stresses according to gyres. -subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - 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 - - ! Local variables - real :: PI, y - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! steady surface wind stresses [Pa] - PI = 4.0*atan(1.0) - - do j=jsd,jed ; do I=IsdB,IedB - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * (CS%gyres_taux_const + & - ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) )) - enddo ; enddo - - do J=JsdB,JedB ; do i=isd,ied - forces%tauy(i,J) = 0.0 - enddo ; enddo - - ! set the friction velocity - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_S * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & - forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) - enddo ; enddo - - call callTree_leave("wind_forcing_gyres") -end subroutine wind_forcing_gyres - -!> This subroutine sets the surface wind stresses by reading a file. -subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the 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(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress - ! units [R Z L T-2 Pa-1 ~> 1] - integer :: days, seconds - - call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - - call get_time(day,seconds,days) - time_lev = days - 365*floor(real(days) / 365.0) +1 - - if (time_lev /= CS%wind_last_lev_read) then - filename = trim(CS%inputdir) // trim(CS%wind_file) -! if (is_root_pe()) & -! write(*,'("Wind_forcing Reading time level ",I," last was ",I,".")')& -! time_lev-1,CS%wind_last_lev_read-1 - select case ( uppercase(CS%wind_stagger(1:1)) ) - case ("A") - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_conversion) - - call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) - enddo ; enddo - - if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) ) / CS%Rho0) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo - endif - case ("C") - call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & - forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev, & - scale=Pa_conversion) - if (CS%wind_scale /= 1.0) then - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = CS%wind_scale * forces%tauy(i,J) - enddo ; enddo - endif - - call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - if (CS%read_gust_2d) then - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt( (CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo - else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) / CS%Rho0) ) - enddo ; enddo - endif - case default - call MOM_error(FATAL, "wind_forcing_from_file: Unrecognized stagger "//& - trim(CS%wind_stagger)//" is not 'A' or 'C'.") - end select - CS%wind_last_lev_read = time_lev - endif ! time_lev /= CS%wind_last_lev_read - - call callTree_leave("wind_forcing_from_file") -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, 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 - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - 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 - - 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 - - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - integer :: time_lev_monthly ! With fields from a file, this must - ! be reset, depending on the time. - integer :: days, seconds - real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - 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. - call get_time(day,seconds,days) - - time_lev = days - 365*floor(real(days) / 365.0) - - if (time_lev < 31) then ; time_lev_monthly = 0 - else if (time_lev < 59) then ; time_lev_monthly = 1 - else if (time_lev < 90) then ; time_lev_monthly = 2 - else if (time_lev < 120) then ; time_lev_monthly = 3 - else if (time_lev < 151) then ; time_lev_monthly = 4 - else if (time_lev < 181) then ; time_lev_monthly = 5 - else if (time_lev < 212) then ; time_lev_monthly = 6 - else if (time_lev < 243) then ; time_lev_monthly = 7 - else if (time_lev < 273) then ; time_lev_monthly = 8 - else if (time_lev < 304) then ; time_lev_monthly = 9 - else if (time_lev < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev = time_lev+1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev /= CS%buoy_last_lev_read) then - -! if (is_root_pe()) & -! write(*,'("buoyancy_forcing : Reading time level ",I3,", last was ",I3,".")')& -! time_lev,CS%buoy_last_lev_read - - - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - 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, 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", & - 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) - 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) - - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - 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, 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 - - call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - 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_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_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_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 - -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then - call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "TEMP", & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SALT", & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - endif - CS%buoy_last_lev_read = time_lev - - ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC - ! assume liquid runoff enters ocean at SST - ! assume solid runoff (calving) enters ocean at 0degC - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = fluxes%evap(i,j) * G%mask2dT(i,j) - fluxes%lprec(i,j) = fluxes%lprec(i,j) * G%mask2dT(i,j) - 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%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) - - 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)*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 - - if (CS%restorebuoy) then - 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) * & - ((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_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - 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 / CS%Rho0) - else - fluxes%buoy(i,j) = 0.0 - endif - enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_from_files") -end subroutine buoyancy_forcing_from_files - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -!! This case has zero surface buoyancy forcing. -subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - 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(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - call callTree_leave("buoyancy_forcing_zero") -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, 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 - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(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 - - ! Local variables - real :: y, T_restore, S_restore - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - ! This case has no surface buoyancy forcing. - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - T_restore = CS%T_south + (CS%T_north-CS%T_south)*y - S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then - 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 - endif - enddo ; enddo - else - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "RESTOREBUOY to linear not written yet.") - !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then - ! 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 - !enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_linear") -end subroutine buoyancy_forcing_linear - -!> Save any restart files associated with the surface forcing. -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< The current model time - character(len=*), intent(in) :: directory !< The directory into which to write the - !! restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file names include - !! a unique time stamp. The default is false. - character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- - !! stamp) to append to the restart file names. - - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - - call save_restart(directory, Time, 1, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of - !! the tracer flow control module. - - ! Local variables - type(directories) :: dirs - logical :: new_sim - type(time_type) :: Time_frc -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. - character(len=60) :: axis_units - character(len=200) :: filename, gust_file ! The name of the gustiness input file. - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('(Ocean surface forcing)', grain=CLOCK_MODULE) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - - ! 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.) - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - - call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) - call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & - "If true, the winds vary in time after the initialization.", & - default=.true.) - call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the "//& - "initialization of the model.", default=.true.) - - call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", default="zero") - if (trim(CS%buoy_config) == "file") then - call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in "//& - "variable lwdn_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in "//& - "variable lwup_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in "//& - "variable evap.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in "//& - "variable shflx.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & - "The file with the upward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEDOWN_FILE", CS%shortwavedown_file, & - "The file with the downward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in "//& - "variable snow.", fail_if_missing=.true.) - call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in "//& - "variable precip.", fail_if_missing=.true.) - call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, "//& - "invariables disch_w and disch_s.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in "//& - "variable TEMP.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to "//& - "restore in variable SALT.", fail_if_missing=.true.) - endif - call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", default="zero") - if (trim(CS%wind_config) == "file") then - call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in "//& - "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) - call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & - "The name of the x-wind stress variable in WIND_FILE.", & - default="STRESS_X") - call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & - "The name of the y-wind stress variable in WIND_FILE.", & - default="STRESS_Y") - call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components "//& - "are staggered in WIND_FILE. This may be A or C for now.", & - default="C") - call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & - "A value by which the wind stresses in WIND_FILE are rescaled.", & - default=1.0, units="nondim") - endif - if (trim(CS%wind_config) == "gyres") then - call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the "//& - "zonal wind stress profile: "//& - " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the "//& - "zonal wind stress profile: "//& - " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in "//& - "the zonal wind stress profile: "//& - " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in "//& - "the zonal wind stress profile: "//& - " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="nondim", default=0.0) - endif - call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent "//& - "starting value for the y-axis.", units=axis_units, default=0.) - call get_param(param_file, mdl, "LENLAT", CS%len_lat, & - "The latitudinal or y-direction length of the domain.", & - units=axis_units, fail_if_missing=.true.) - 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, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - 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 to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_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 "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - endif - endif - 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_L**2*US%Z_to_m*US%T_to_s**2) - - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - 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.) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.", fail_if_missing=.true.) - call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'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, "AXIS_UNITS", axis_units, default="degrees") - -! All parameter settings are now known. - - if (trim(CS%wind_config) == "USER" .or. trim(CS%buoy_config) == "USER" ) then - call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) - elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") - endif - - call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) - - ! Set up any restart fields associated with the forcing. - call restart_init(G, param_file, CS%restart_CSp, "MOM_forcing.res") - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Clean up and deallocate any memory associated with this module and its children. -subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous surface_forcing_init call - !! that will be deallocated here. - type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible - !! forcing fields that will be deallocated here. - - if (present(fluxes)) call deallocate_forcing_type(fluxes) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -end module MOM_surface_forcing diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index f2c5099544..9113b60c64 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -1,4 +1,4 @@ -program SHELF_main +program Shelf_main ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,92 +21,104 @@ program SHELF_main !* * !********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end - use MOM_domains, only : MOM_infra_init, MOM_infra_end - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : close_param_file -! use MOM_grid, only : ocean_grid_type - use MOM_get_input, only : Get_MOM_Input, directories - use MOM_io, only : file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart -! use MOM_sum_output, only : write_energy, accumulate_net_input -! use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS - use MOM_string_functions, only : uppercase -! use MOM_surface_forcing, only : set_forcing, average_forcing -! use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real - use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) - use MOM_time_manager, only : operator(>), operator(<), operator(>=) - use MOM_time_manager, only : increment_date, set_calendar_type, month_name - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR - use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init - use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end + use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_debugging, only : MOM_debugging_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end + use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe + use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint + use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type + use MOM_file_parser, only : close_param_file + use MOM_fixed_initialization, only : MOM_initialize_fixed + use MOM_get_input, only : Get_MOM_Input, directories + use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_io, only : MOM_io_init, file_exists, open_file, close_file + use MOM_io, only : check_nml_error, io_infra_init, io_infra_end + use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_open_boundary, only : ocean_OBC_type + use MOM_restart, only : save_restart + use MOM_string_functions,only : uppercase + use MOM_time_manager, only : time_type, set_date, get_date + use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) + use MOM_time_manager, only : operator(>), operator(<), operator(>=) + use MOM_time_manager, only : increment_date, set_calendar_type, month_name + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR + 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 + use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd + use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init + use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf -! , add_shelf_flux_forcing, add_shelf_flux_IOB + implicit none #include - -! type(forcing) :: fluxes ! A structure that will be uninitialized till i figure out - ! whether i can make the argument optional - -! type(ocean_grid_type), pointer :: grid ! A pointer to a structure containing - ! metrics and related information. logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for ! part of the domain. - logical :: permit_restart = .true. ! This is .true. if incremental restart - ! files may be saved. - integer :: m, n - - integer :: nmax=2000000000; ! nmax is the number of iterations - ! after which to stop so that the - ! simulation does not exceed its CPU - ! time limit. nmax is determined by - ! evaluating the CPU time used between - ! successive calls to write_energy. - ! Initially it is set to be very large. - type(directories) :: dirs ! A structure containing several relevant directory paths. - - type(time_type), target :: Time ! A copy of the model's time. - ! Other modules can set pointers to this and - ! change it to manage diagnostics. - - type(time_type) :: Master_Time ! The ocean model's master clock. No other - ! modules are ever given access to this. - - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - - type(time_type) :: Start_time ! The start time of the simulation. + ! This is .true. if incremental restart files may be saved. + logical :: permit_incr_restart = .true. + + integer :: ns ! Running number of external timesteps. + integer :: ns_ice ! Running number of internal timesteps in solo_step_ice_shelf. + + ! nmax is the number of iterations after which to stop so that the simulation does not exceed its + ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to + ! write_cputime. Initially it is set to be very large. + integer :: nmax=2000000000 + + ! A structure containing several relevant directory paths. + type(directories) :: dirs + + ! A suite of time types for use by the solo ice model. + type(time_type), target :: Time ! A copy of the model's time. + ! Other modules can set pointers to this and + ! change it to manage diagnostics. + type(time_type) :: Master_Time ! The ocean model's master clock. No other + ! modules are ever given access to this. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + type(time_type) :: Start_time ! The start time of the simulation. type(time_type) :: segment_start_time ! The start time of this run segment. + type(time_type) :: Time_end ! End time for the segment or experiment. + type(time_type) :: restart_time ! The next time to write restart files. + type(time_type) :: Time_step_shelf ! A time_type version of time_step. + type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time + ! and elapsed time to avoid roundoff problems. - type(time_type) :: Time_end ! End time for the segment or experiment. + real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - type(time_type) :: restart_time ! The next time to write restart files. - - type(time_type) :: Time_step_shelf ! A time_type version of time_step. + logical :: elapsed_time_master ! If true, elapsed time is used to set the + ! model's master clock (Time). This is needed + ! if Time_step_shelf is not an exact + ! representation of time_step. + real :: time_step ! The time step [s] - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. (years?) + ! A pointer to a structure containing metrics and related information. + type(ocean_grid_type), pointer :: ocn_grid - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_shelf is not an exact - ! representation of time_step. + type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the ocean vertical grid structure - real :: time_step ! The time step (in years??? seconds???) + !> Pointer to the MOM open boundary condition type + type(ocean_OBC_type), pointer :: OBC => NULL() + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US + type(diag_ctrl), pointer :: & + diag => NULL() ! A pointer to the diagnostic regulatory structure integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -114,41 +126,40 @@ program SHELF_main ! files and +2 (bit 1) for time-stamped files. A ! restart file is saved at the end of a run segment ! unless Restart_control is negative. - real :: Time_unit ! The time unit in seconds for the following input fields. + + real :: Time_unit ! The time unit for the following input fields [s]. type(time_type) :: restint ! The time between saves of the restart file. type(time_type) :: daymax ! The final day of the simulation. - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. + integer :: CPU_steps ! The number of steps between writing CPU time. + integer :: date_init(6)=0 ! The start date of the whole simulation. + integer :: date(6)=-1 ! Possibly the start date of this run segment. integer :: years=0, months=0, days=0 ! These may determine the segment run integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, min, sec ! Temp variables for writing the date. - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - character(len=9) :: month + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + type(param_file_type) :: param_file ! The structure indicating the file(s) + ! containing all run-time parameters. + character(len=9) :: month character(len=16) :: calendar = 'julian' integer :: calendar_type=-1 integer :: unit, io_status, ierr - logical :: unit_in_use + logical :: symmetric + logical :: unit_in_use integer :: initClock, mainClock, termClock -! type(ice_shelf_CS), pointer :: MOM_CSp => NULL() -! type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() -! type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() !----------------------------------------------------------------------- - character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "SHELF_main (ice_shelf_driver)" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mod_name = "SHELF_main (ice_shelf_driver)" ! This module's name. namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds - !======================================================================= + !===================================================================== call write_cputime_start_clock(write_CPU_CSp) @@ -160,15 +171,16 @@ program SHELF_main termClock = cpu_clock_id( 'Termination' ) call cpu_clock_begin(initClock) - call MOM_mesg('======== Model being driven by ice_shelf_driver ========') + call MOM_mesg('======== Model being driven by ice_shelf_driver ========', 2) + call callTree_waypoint("Program Shelf_main, ice_shelf_driver.F90") if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) read(unit, ice_solo_nml, iostat=io_status) call close_file(unit) + ierr = check_nml_error(io_status,'ice_solo_nml') if (years+months+days+hours+minutes+seconds > 0) then - ierr = check_nml_error(io_status,'ice_solo_nml') if (is_root_pe()) write(*,ice_solo_nml) endif endif @@ -184,38 +196,40 @@ program SHELF_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then - call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then + call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') else - call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') + call MOM_error(FATAL,'Shelf_driver: No namelist value for calendar') endif endif call set_calendar_type(calendar_type) + if (sum(date_init) > 0) then Start_time = set_date(date_init(1),date_init(2), date_init(3), & date_init(4),date_init(5),date_init(6)) else - Start_time = set_time(0,0) + Start_time = real_to_time(0.0) endif call Get_MOM_Input(param_file, dirs) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, US) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mod_name, version, "") - call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & "If true, call the code to apply an ice shelf model over "//& "some of the domain.", default=.false.) - if (.not.use_ice_shelf) call MOM_error(FATAL, & - "shelf_driver: ICE_SHELF must be defined.") + if (.not.use_ice_shelf) call MOM_error(FATAL, "Shelf_driver: Run stops unless ICE_SHELF is true.") - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & + call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -224,39 +238,70 @@ program SHELF_main ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) else - ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. + ! In this case, the segment starts at Start_time. Time = Start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) endif + + ! This is the start of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("Start of ice shelf initialization.") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, + ! but the grids have strong commonalities in this configuration, and the ocean grid is required + ! to set up the diag mediator control structure. + call MOM_domains_init(ocn_grid%domain, param_file) + call hor_index_init(ocn_grid%Domain, HI, param_file) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(ocn_grid%Domain, dG%Domain) + + ! Initialize the ocean grid and topography. + call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_grid_init(ocn_grid, param_file, US, HI) + call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) + call destroy_dyn_horgrid(dG) + + ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at + ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. + call verticalGridInit(param_file, GV, US) + call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + + call callTree_waypoint("returned from diag_mediator_init()") + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + + ! This is the end of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("End of ice shelf initialization.") + Master_Time = Time ! grid => ice_shelf_CSp%grid segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = set_time(int(floor(time_step+0.5))) + Time_step_shelf = real_to_time(time_step) elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) if (elapsed_time_master) & - call MOM_mesg("Using real elapsed time for the master clock.") + call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & + call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX and RESTINT.", & units="s", default=86400.0) if (years+months+days+hours+minutes+seconds > 0) then Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) - call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) - call get_param(param_file, mdl, "DAYMAX", daymax, & + call MOM_mesg('Segment run length determined from ice_solo_nml.', 2) + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& "not set (as it was here) via ocean_solo_nml in input.nml.", & timeunit=Time_unit, default=Time_end) else - call get_param(param_file, mdl, "DAYMAX", daymax, & + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& @@ -265,58 +310,62 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & - "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & - "MOM_driver: The run has been started at or after the end time of the run.") + "Shelf_driver: The run has been started at or after the end time of the run.") - call get_param(param_file, mdl, "RESTART_CONTROL", Restart_control, & + call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & "An integer whose bits encode which restart files are "//& "written. Add 2 (bit 1) for a time-stamped file, and odd "//& "(bit 0) for a non-time-stamped file. A non-time-stamped "//& "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) - call get_param(param_file, mdl, "RESTINT", restint, & + call get_param(param_file, mod_name, "RESTINT", restint, & "The interval between saves of the restart file in units "//& "of TIMEUNIT. Use 0 (the default) to not save "//& - "incremental restart files at all.", default=set_time(0), & + "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) - call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) -! i don't think we'll use this... - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call MOM_mesg("Done MOM_write_cputime_init.", 5) + call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) -! call diag_mediator_close_registration(diag) + call diag_mediator_close_registration(diag) ! Write out a time stamp file. - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - - call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (calendar_type /= NO_CALENDAR) then + call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & + threading=SINGLE_FILE) + call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call close_file(unit) + endif + + if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & - .or. (Restart_control < 0)) permit_restart = .false. + .or. (Restart_control < 0)) permit_incr_restart = .false. - if (restint > set_time(0)) then + if (restint > real_to_time(0.0)) then ! restart_time is the next integral multiple of restint. restart_time = Start_time + restint * & - (1 + ((Time + Time_step_ocean) - Start_time) / restint) + (1 + ((Time + Time_step_shelf) - Start_time) / restint) else ! Set the time so late that there is no intermediate restart. - restart_time = Time_end + Time_step_ocean - permit_restart = .false. + restart_time = Time_end + Time_step_shelf + permit_incr_restart = .false. endif call cpu_clock_end(initClock) !end initialization @@ -325,66 +374,72 @@ program SHELF_main !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n = 1 ; m = 1 - do while ((n < nmax) .and. (Time < Time_end)) + ns = 1 ; ns_ice = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, Shelf_driver.F90", ns) ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) -! Time = Time + Time_step_ocean -! This is here to enable fractional-second time steps. +! Time = Time + Time_step_shelf +! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not loose resolution of order - ! the timetype's resolution, provided that the timestep and tick are - ! larger than 10-5 seconds. If a clock with a finer resolution is used, - ! a smaller value would be required. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time(elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) + Master_Time = segment_start_time + real_to_time(elapsed_time) else Master_Time = Master_Time + Time_step_shelf endif Time = Master_Time + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns, nmax, write_CPU_CSp) + endif ; endif + ! See if it is time to write out a restart file - timestamped or not. - if (permit_restart) then - if (Time + (Time_step_shelf/2) > restart_time) then - if (BTEST(Restart_control,1)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) - endif - if (BTEST(Restart_control,0)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) - endif - restart_time = restart_time + restint + if ((permit_incr_restart) .and. (Time + (Time_step_shelf/2) > restart_time)) then + if (BTEST(Restart_control,1)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) endif + if (BTEST(Restart_control,0)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) + endif + restart_time = restart_time + restint endif - enddo !!!!!!! end loop + ns = ns + 1 + call callTree_leave("Main loop") + enddo call cpu_clock_end(mainClock) call cpu_clock_begin(termClock) if (Restart_control>=0) then call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - ! Write ocean solo restart file. + + ! Write ice shelf solo restart file. call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) if (is_root_pe())then write(unit, '(i6,8x,a)') calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - call get_date(Start_time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif @@ -402,11 +457,12 @@ program SHELF_main close(unit) endif - call diag_mediator_end(Time, ice_shelf_CSp%diag, end_diag_manager=.true.) + call callTree_waypoint("End Shelf_main") + call diag_mediator_end(Time, diag, end_diag_manager=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end call ice_shelf_end(ice_shelf_CSp) -end program SHELF_main +end program Shelf_main diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 deleted file mode 100644 index 64c4b4ce0a..0000000000 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ /dev/null @@ -1,338 +0,0 @@ -module user_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* USER_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* USER_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, lprec, fprec, lrunoff, frunoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init - -! 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. - -type, public :: user_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - - 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]. - 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 [R Z L T-1 ~> Pa]. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. -end type user_surface_forcing_CS - -contains - -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. -!! These are the stresses in the direction of the model grid (i.e. the same -!! direction as the u- and v- velocities). -subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< The time of the 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(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [R Z L T-2 ~> Pa]. -! In addition, this subroutine can be used to set the surface friction velocity, -! forces%ustar [Z T-1 ~> m s-1], which is needed with a bulk mixed layer. - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses [Pa]. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then ; 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%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo ; enddo ; endif - -end subroutine USER_wind_forcing - -!> This subroutine specifies the current surface fluxes of buoyancy or -!! temperature and fresh water. It may also be modified to add -!! surface fluxes of user provided tracers. -subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, 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 - type(time_type), intent(in) :: day !< The time of the fluxes - 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(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! When temperature is used, there are long list of fluxes that need to be -! set - essentially the same as for a full coupled model, but most of these -! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%lprec, with any salinity restoring -! appearing in fluxes%vprec, and the other water flux components -! (fprec, lrunoff and frunoff) left as arrays full of zeros. -! Evap is usually negative and precip is usually positive. All heat fluxes -! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. - - 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 [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]. - - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "User forcing routine called without modification." ) - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) - - call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) - else ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - - if ( CS%use_temperature ) then - ! 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] - ! 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) - - ! 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) = 0.0 * G%mask2dT(i,j) - fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Temperature and salinity restoring used without modification." ) - - 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 * 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)))) - enddo ; enddo - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "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) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! 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 * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine USER_buoyancy_forcing - -!> This subroutine initializes the USER_surface_forcing module -subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to - !! the control structure for this module - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "user_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "USER_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "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.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - 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) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) - endif - -end subroutine USER_surface_forcing_init - -end module user_surface_forcing From f5df25d23ef2913eb16e6a81de9609a878af0ca0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 20 Jul 2020 10:54:12 -0400 Subject: [PATCH 167/256] Move FMS tag to 2019.01.03 - FMS tag 2019.01.03 fixes problems for EMC allowing the newer FV3 to work with MOM6 which is not yet compatible with FMS2020. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index bc03358649..d1ceb16577 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.02 +FMS_COMMIT ?= 2019.01.03 FMS := $(DEPS)/fms #--- From 535b43ca3bac44215dfa9251817fd5d6f8306573 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Jul 2020 11:03:12 -0400 Subject: [PATCH 168/256] Avoid using uninitialized arrays Modified recent additions to avoid using uninitialized arrays. This was not detected in tests of the previous PR because the arrays that were created from uninitialized arrays were themselves never used, so there are no answer changes but there were errors with intolerant compiler settings. Also corrected the dOxygen syntax in a comment and corrected some openMP directives that had been triggering warnings or errors. All answers are bitwise identical. --- src/core/MOM_CoriolisAdv.F90 | 2 +- src/core/MOM_barotropic.F90 | 58 +++++++++++-------- .../vertical/MOM_vert_friction.F90 | 4 +- 3 files changed, 38 insertions(+), 26 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 2f96839ed5..f470338c4e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -256,7 +256,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9e62e84f3b..7f34f18998 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1156,16 +1156,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ! Calculate the initial barotropic velocities from the layer's velocities. - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + enddo ; enddo + endif !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) @@ -2203,20 +2214,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Update the summed and integrated quantities from the saved previous values. ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) - ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) - uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif 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 ! Update the summed and integrated quantities from the saved previous values. vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) - vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) - vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif endif enddo ; enddo ; endif endif @@ -2731,7 +2746,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity !! equation directly from the initial condition !! using the time-integrated barotropic velocity. real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping @@ -2918,7 +2933,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity !! equation directly from the initial condition !! using the time-integrated barotropic velocity. real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of @@ -3774,11 +3789,8 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,hs,BTCL_u,FA_u_EE,FA_u_E0,FA_u_W0, & -!$OMP FA_u_WW,uBT_EE,uBT_WW,u_polarity,BTCL_v, & -!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,vBT_NN,vBT_SS, & -!$OMP v_polarity ) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) @@ -3801,7 +3813,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = & (C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2 enddo ; enddo -!$OMP do + !$OMP do do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) @@ -3824,7 +3836,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = & (C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2 enddo ; enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_local_BT_cont_types diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b1a37c7d5e..f03cee72b8 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -679,7 +679,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -846,7 +846,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! Now work on v-points. !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo From 2a9248af4f790f44626bc145b4da78b10e1ae664 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Jul 2020 17:12:30 -0400 Subject: [PATCH 169/256] Added missing openMP directives Added some missing openMP directives that had been triggering warnings or errors, and could have created problems with more extensive testing. Also set some unset array bounds in the ice_shelf_dynamics code. All answers are bitwise identical in all working test cases. --- src/diagnostics/MOM_wave_speed.F90 | 3 ++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1 + src/parameterizations/vertical/MOM_kappa_shear.F90 | 6 +++--- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 9da2963c16..b3321cdace 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -806,7 +806,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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) + !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & + !$OMP c1_thresh,tol_solve,tol_merge) 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 diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index be3ae1ecde..0c9fe4e77e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1405,6 +1405,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after 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] + 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 diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 096781f8cf..04e67f0be5 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -396,8 +396,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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]. real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. - real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. - real :: I_Prandtl + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. logical :: new_kappa = .true. ! If true, ignore the value of kappa from the @@ -422,7 +422,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,new_kappa, & - !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 From 5680fe5acda729514280956616fcd0f57c8b91ee Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 27 Jul 2020 08:12:32 -0400 Subject: [PATCH 170/256] Fixing loop bound error in MOM_PressureForce_Montgomery.F90 The "for" loop at L510 should be to nz instead of nz+1. Due to array allocation sizes, this loop was extending beyond the shope of the argument arrays. --- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 07cbf3adf4..cade4e074d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -507,7 +507,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! This no longer includes any pressure dependency, since this routine ! 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 + 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_star(:,j,k), & tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo From 652975250eabd5ef1365e7e3496bf4bd418dec3d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 27 Jul 2020 10:27:15 -0400 Subject: [PATCH 171/256] Testing: tc4 installs python-netCDF4 via venv (#1166) Squash merge of following commits: * Testing: tc4 installs python-netCDF4 via venv Currently, users are expected to have numpy and netcdf4 python modules in order to generate the necessary netCDF input files. This fails in environments where these modules are unavailable. This patch now installs the modules into a virtual environment which are accessible when generating the tc4 inputs. This solution is local to tc4 but could be extended to other tests as needed. * Testing: remove Python numpy and netCDF4 modules The numpy and netCDF4 packages are no longer needed since tc4 now installs these locally. * Test: Install virtualenv for Python2 tc4 was using the venv module which appears to be python3-specific, and Travis Ubuntu defaults to python2. Also virtualenv was not installed in either case. This patch adds python-virtualenv to the install packages and uses the virtualenv module. * Test: Add python-dev for ARM64 numpy Travis ARM nodes need to build numpy natively when installed by pip, and thus require Python headers. These are provided by the python-dev package. * Test: Revert to Py3 for tc4 generation scripts Reverting the python 2 support (default for Travis) to use Python 3 syntax. The main reason is that Python 3 includes venv (equivalent to virtualenv) as its standard library, and is therefore guaranteed to exist if Python 3 exists. Python 3's virtualenv must be independently installed, which cannot be confirmed. This will cause problems for people without Python 3, but this is probably the best solution, or at least the starting point for a more general solution. * Test: Adding python3-venv to Travis Ubuntu apparently requires an explicit install of python3-venv despite it being part of the standard library. Go figure... * Test: Arm64 tc4 Configuration support Arm64 Ubuntu environments require explicit installations which are otherwise provided on x86 Ubuntu: * Python 3 Pip must be installed (python3-pip) * Wheel installation must be explicitly installed * Cython is required for numpy * Numpy must be explicitly built before installing python-netCDF4 * Test: tc4 common Python local-env Build times for setting up the virtual environments can be very expensive on the Arm64 Ubuntu nodes, so we now create a shared directory for launching the environments. * Test: Use '.' in place of 'source' for Make * Test: Test for required Python modules in tc4 We have reworked the Makefile to conditionally test for required Python modules in tc4. If unavailable, we install these in a virtual environment. This does not address many scenarios, such as if Python 3 is missing, venv is missing (as in Ubuntu), or handle the situation if they do not exist. It assumes that either the modules exist, or that they can be installed by venv. This should be seen as an iterative step to get things working on Travis x86 and Arm64, as well as GFDL's Gaea and most user Linux platforms. * Test: Explicit python execs for tc4 input build This resolves some issues with python2/3 resolution and limited support of various platforms for module support. Specifically, older platform with basic Python 3 support may not also have numpy support. In this case, we can defer back to Python 2 (or whatever the system Python may be). * Test: Setup Python venv at build time This patch moves the Python virtual environment configuration to the main Makefile, which is setup at build time, rather than in the model configuration Makefile, which will typically not have internet access if run on a compute node. As before, the venv will only be setup when the numpy and netCDF4 modules are unavailable. A minor bug in the logic of the check has also been fixed. --- .testing/Makefile | 54 ++++++++++++++++++++++++++++++++++++++--- .testing/tc4/.gitignore | 4 +++ .testing/tc4/Makefile | 7 +++++- .travis.yml | 1 + 4 files changed, 61 insertions(+), 5 deletions(-) create mode 100644 .testing/tc4/.gitignore diff --git a/.testing/Makefile b/.testing/Makefile index d1ceb16577..ab978fdadc 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -92,11 +92,34 @@ TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) +#--- +# Python preprocessing environment configuration + +HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") +HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") + +USE_VENV = +ifneq ($(HAS_NUMPY), yes) + USE_VENV = yes +endif +ifneq ($(HAS_NETCDF4), yes) + USE_VENV = yes +endif + +# When disabled, activation is a null operation (`true`) +VENV_PATH = +VENV_ACTIVATE = true +ifeq ($(USE_VENV), yes) + VENV_PATH = work/local-env + VENV_ACTIVATE = . $(VENV_PATH)/bin/activate +endif + + #--- # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -184,6 +207,18 @@ $(LIST_PATHS) $(MKMF): cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) +#--- +# Python preprocessing +# NOTE: Some less mature environments (e.g. Arm64 Ubuntu) require explicit +# installation of numpy before netCDF4, as well as wheel and cython support. +work/local-env: + python3 -m venv $@ + . $@/bin/activate \ + && pip3 install wheel \ + && pip3 install cython \ + && pip3 install numpy \ + && pip3 install netCDF4 + #---- # Testing @@ -264,7 +299,6 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # TODO: chksum_diag parsing of restart files - #--- # Test run output files @@ -281,7 +315,13 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) cp -rL $$*/* $$(@D) - cd $$(@D) && if [ -f Makefile ]; then $(MAKE); fi + if [ -f $$(@D)/Makefile ]; then \ + $$(VENV_ACTIVATE) \ + && cd $$(@D) \ + && $(MAKE); \ + else \ + cd $$(@D); \ + fi mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ @@ -327,7 +367,13 @@ 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 + if [ -f $(@D)/Makefile ]; then \ + $(VENV_ACTIVATE) \ + && cd work/$*/restart \ + && $(MAKE); \ + else \ + cd work/$*/restart; \ + fi mkdir -p $(@D)/RESTART # Generate the half-period input namelist # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore new file mode 100644 index 0000000000..29f62fb208 --- /dev/null +++ b/.testing/tc4/.gitignore @@ -0,0 +1,4 @@ +ocean_hgrid.nc +sponge.nc +temp_salt_ic.nc +topog.nc diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile index c332bbd7e6..a9aa395b9c 100644 --- a/.testing/tc4/Makefile +++ b/.testing/tc4/Makefile @@ -1,3 +1,8 @@ -ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc: +OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc + +$(OUT): python build_grid.py python build_data.py + +clean: + rm -rf $(OUT) diff --git a/.travis.yml b/.travis.yml index 6bf509ce8c..10816b7122 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,6 +14,7 @@ addons: - mpich libmpich-dev - doxygen graphviz flex bison cmake - python-numpy python-netcdf4 + - python3 python3-dev python3-venv python3-pip - bc jobs: From 4c030e613a66e57ef6bdd14504fb5ae877af473c Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Wed, 29 Jul 2020 08:44:37 -0400 Subject: [PATCH 172/256] Momentum budget terms multiplied by fractional layer-thicknesses (#1163) Squash merge: * New diagnostics for barotropic momentum budget calculations are created. In these, different budget terms multiplied by fractional layer thicknesses are saved. Thus, these terms can be added over the whole to obtain the barotropic momentum budget. 'btstep' subroutine in MOM_barotropic module is modified to return fractional thicknesses. Pressure force acceleration multiplied by fractional thickness as diagnostics are added in this commit. * More thickness weighted diagnostics * Implemented Andrew Shao's suggestions * More fractional thickness multiplied diagnostics * Some barotropic diagnostics obtained from fractional thickness multiplied momentum budget terms * Removed trailing spaces * All fractional-thickness multiplied diagnostics implemented * define diagnostic variables as pointers * Shorter initialization of 2D arrays * Modifications in vertical friction diagnostics * Diagnostics initialization as pointers to save memory allocation * Vertical friction module * Removed commented lines and trailing spaces * Diagnostic description change * Fractional thickness-weighted diagnostics for acceleration due to relative vorticity and gradient of kinetic energy * Modifications in vertical friction diagnostics (fractional thickness-weighted) * Modifications in diag_hfrac_u and diag_hfrac_v calls * Made allocation of hfrac at u/v points optional. These arrays are only allocated if any of the relevant diagnostics are called. * Fractional-thickness weighted 3D diagnostics are now commented out as we do not the proper grid remapping option. * Initialization of 2D diagnostic arrays changed from pointer type to allocatable array style. * Trailing spaces removed and line lengths reduced to be under 120 characters * Comment modified Reviewed by Robert Hallberg --- src/core/MOM_CoriolisAdv.F90 | 154 ++++++++++++++ src/core/MOM_barotropic.F90 | 15 +- src/core/MOM_dynamics_split_RK2.F90 | 193 +++++++++++++++++- src/core/MOM_variables.F90 | 2 + src/diagnostics/MOM_diagnostics.F90 | 93 +++++++++ .../lateral/MOM_hor_visc.F90 | 83 +++++++- .../vertical/MOM_vert_friction.F90 | 84 +++++++- 7 files changed, 614 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index f470338c4e..cf274d32a9 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -74,6 +74,10 @@ module MOM_CoriolisAdv !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 integer :: id_rvxu = -1, id_rvxv = -1 + ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 + integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 + integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -211,6 +215,16 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: QUHeff,QVHeff ! More temporary variables [H L2 T-1 s-1 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz +! Diagnostics for fractional thickness-weighted terms + real, allocatable, dimension(:,:) :: & + hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. + hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. + !real, allocatable, dimension(:,:,:) :: & + ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. + ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: ! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), @@ -828,6 +842,82 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_gKEu > 0) then + ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEu, hf_gKEu, CS%diag) + !endif + + !if (CS%id_hf_gKEv > 0) then + ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEv, hf_gKEv, CS%diag) + !endif + + if (CS%id_hf_gKEu_2d > 0) then + allocate(hf_gKEu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_gKEu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_gKEu_2d(I,j) = hf_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEu_2d, hf_gKEu_2d, CS%diag) + deallocate(hf_gKEu_2d) + endif + + if (CS%id_hf_gKEv_2d > 0) then + allocate(hf_gKEv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_gKEv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_gKEv_2d(i,J) = hf_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEv_2d, hf_gKEv_2d, CS%diag) + deallocate(hf_gKEv_2d) + endif + + !if (CS%id_hf_rvxv > 0) then + ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxv, hf_rvxv, CS%diag) + !endif + + !if (CS%id_hf_rvxu > 0) then + ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxu, hf_rvxu, CS%diag) + !endif + + if (CS%id_hf_rvxv_2d > 0) then + allocate(hf_rvxv_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_rvxv_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_rvxv_2d(I,j) = hf_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxv_2d, hf_rvxv_2d, CS%diag) + deallocate(hf_rvxv_2d) + endif + + if (CS%id_hf_rvxu_2d > 0) then + allocate(hf_rvxu_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_rvxu_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_rvxu_2d(i,J) = hf_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) + deallocate(hf_rvxu_2d) + endif endif end subroutine CorAdCalc @@ -1087,6 +1177,70 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Zonal Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEu > 0) then + ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEv > 0) then + ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEu_2d > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCvL, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEv_2d > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxu > 0) then + ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxv > 0) then + ! call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCvL, Time, & + 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxu_2d > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxv_2d > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7f34f18998..db85bb40e2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -27,6 +27,7 @@ module MOM_barotropic use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -405,7 +406,7 @@ module MOM_barotropic subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & - visc_rem_u, visc_rem_v, etaav, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, etaav, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -458,6 +459,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass !! averaged over the barotropic integration [H ~> m or kg m-2]. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic @@ -2583,6 +2585,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_u))) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_v))) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif + if (G%nonblocking_updates) then if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 276c3c330f..64a9c18b97 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -160,10 +160,16 @@ module MOM_dynamics_split_RK2 integer :: id_umo_2d = -1, id_vmo_2d = -1 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -318,6 +324,19 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + ! real, allocatable, dimension(:,:,:) :: & + ! hf_PFu, hf_PFv, & ! Pressure force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_CAu, hf_CAv, & ! Coriolis force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_u_BT_accel, hf_v_BT_accel ! barotropic correction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + + real, allocatable, dimension(:,:) :: & + hf_PFu_2d, hf_PFv_2d, & ! Depth integeral of hf_PFu, hf_PFv [L T-2 ~> m s-2]. + hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. + hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -532,7 +551,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! This is the predictor step call to btstep. call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & - G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & + G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, ADp=CS%ADp, & OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) @@ -682,7 +701,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -733,8 +753,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & - CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & - BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & + CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, ADp=CS%ADp, & + OBC=CS%OBC, BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo @@ -860,6 +880,109 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_PFu > 0) then + ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFu, hf_PFu, CS%diag) + !endif + !if (CS%id_hf_PFv > 0) then + ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFv, hf_PFv, CS%diag) + !endif + if (CS%id_hf_PFu_2d > 0) then + allocate(hf_PFu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_PFu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_PFu_2d(I,j) = hf_PFu_2d(I,j) + CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFu_2d, hf_PFu_2d, CS%diag) + deallocate(hf_PFu_2d) + endif + if (CS%id_hf_PFv_2d > 0) then + allocate(hf_PFv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_PFv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_PFv_2d(i,J) = hf_PFv_2d(i,J) + CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFv_2d, hf_PFv_2d, CS%diag) + deallocate(hf_PFv_2d) + endif + + !if (CS%id_hf_CAu > 0) then + ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAu, hf_CAu, CS%diag) + !endif + !if (CS%id_hf_CAv > 0) then + ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAv, hf_CAv, CS%diag) + !endif + if (CS%id_hf_CAu_2d > 0) then + allocate(hf_CAu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_CAu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_CAu_2d(I,j) = hf_CAu_2d(I,j) + CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAu_2d, hf_CAu_2d, CS%diag) + deallocate(hf_CAu_2d) + endif + if (CS%id_hf_CAv_2d > 0) then + allocate(hf_CAv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_CAv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_CAv_2d(i,J) = hf_CAv_2d(i,J) + CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAv_2d, hf_CAv_2d, CS%diag) + deallocate(hf_CAv_2d) + endif + + !if (CS%id_hf_u_BT_accel > 0) then + ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_u_BT_accel, hf_u_BT_accel, CS%diag) + !endif + !if (CS%id_hf_v_BT_accel > 0) then + ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_v_BT_accel, hf_v_BT_accel, CS%diag) + !endif + if (CS%id_hf_u_BT_accel_2d > 0) then + allocate(hf_u_BT_accel_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_u_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_u_BT_accel_2d(I,j) = hf_u_BT_accel_2d(I,j) + CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_u_BT_accel_2d, hf_u_BT_accel_2d, CS%diag) + deallocate(hf_u_BT_accel_2d) + endif + if (CS%id_hf_v_BT_accel_2d > 0) then + allocate(hf_v_BT_accel_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_v_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_v_BT_accel_2d(i,J) = hf_v_BT_accel_2d(i,J) + CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_v_BT_accel_2d, hf_v_BT_accel_2d, CS%diag) + deallocate(hf_v_BT_accel_2d) + endif + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1110,7 +1233,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 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, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & @@ -1232,6 +1355,46 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & @@ -1242,6 +1405,26 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 26c2344f44..0b225f0bf7 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -185,6 +185,8 @@ module MOM_variables real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points end type accel_diag_ptrs !> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d51173c16b..3936a788d0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -71,6 +71,9 @@ module MOM_diagnostics dv_dt => NULL(), & !< net j-acceleration [L T-2 ~> m s-2] dh_dt => NULL(), & !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] + ! hf_du_dt => NULL(), hf_dv_dt => NULL() !< du_dt, dv_dt x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density !! coordinates [H ~> m or kg m-2] @@ -110,6 +113,8 @@ module MOM_diagnostics integer :: id_u = -1, id_v = -1, id_h = -1 integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 + ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_Coradv = -1 @@ -233,6 +238,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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] + real, allocatable, dimension(:,:) :: & + hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + ! 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] @@ -272,6 +280,44 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt, CS%hf_du_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + !if (CS%id_hf_dv_dt > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt, CS%hf_dv_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + if (CS%id_hf_du_dt_2d > 0) then + allocate(hf_du_dt_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_2d(I,j) = hf_du_dt_2d(I,j) + CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_2d, hf_du_dt_2d, CS%diag) + deallocate(hf_du_dt_2d) + endif + + if (CS%id_hf_dv_dt_2d > 0) then + allocate(hf_dv_dt_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_2d(i,J) = hf_dv_dt_2d(i,J) + CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_2d, hf_dv_dt_2d, CS%diag) + deallocate(hf_dv_dt_2d) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -1644,6 +1690,50 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif + !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) + ! if (.not.associated(CS%du_dt)) then + ! call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + ! call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) + ! if (.not.associated(CS%dv_dt)) then + ! call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + ! call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_2d > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_2d = register_diag_field('ocean_model', 'hf_dvdt_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_2d > 0) then + if (.not.associated(CS%dv_dt)) then + call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & @@ -2178,6 +2268,9 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%du_other)) deallocate(ADp%du_other) if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) + if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo deallocate(CS) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 7c1405308f..4e9897f6eb 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -19,6 +19,7 @@ module MOM_hor_visc use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -174,9 +175,16 @@ module MOM_hor_visc type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics + ! real, pointer :: hf_diffu(:,:,:) => NULL() ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_diffv(:,:,:) => NULL() ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !>@{ !! Diagnostic id integer :: id_diffu = -1, id_diffv = -1 + ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 @@ -203,7 +211,7 @@ module MOM_hor_visc !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD) + CS, OBC, BT, TD, ADp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -230,6 +238,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! barotropic velocities. type(thickness_diffuse_CS), optional, pointer :: TD !< Pointer to a structure containing !! thickness diffusivities. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] @@ -263,6 +273,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + real, allocatable, dimension(:,:) :: hf_diffu_2d ! Depth sum of hf_diffu [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_diffv_2d ! Depth sum of hf_diffv [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -1307,12 +1320,47 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (present(ADp) .and. (CS%id_hf_diffu > 0)) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_diffu(I,j,k) = diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffu, CS%hf_diffu, CS%diag) + !endif + !if (present(ADp) .and. (CS%id_hf_diffv > 0)) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_diffv(i,J,k) = diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) + !endif + if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then + allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + deallocate(hf_diffu_2d) + endif + if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then + allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + deallocate(hf_diffv_2d) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). !! hor_visc_init calculates and stores the values of a number of metric functions that !! are used in horizontal_viscosity(). -subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) +subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) type(time_type), intent(in) :: Time !< Current model 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 @@ -1321,6 +1369,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. type(hor_visc_CS), pointer :: CS !< Pointer to the control structure for this module type(MEKE_type), pointer :: MEKE !< MEKE data + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v @@ -2016,6 +2065,36 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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) + !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + !endif + + !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + !endif + + CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + endif + + CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + endif + 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, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index f03cee72b8..c6a6f37b39 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -124,10 +124,18 @@ module MOM_vert_friction integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + + ! real, pointer :: hf_du_dt_visc(:,:,:) => NULL() ! Zonal friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_dv_dt_visc(:,:,:) => NULL() ! Merdional friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + end type vertvisc_CS contains @@ -202,11 +210,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing - integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & @@ -453,6 +464,41 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt_visc, CS%hf_du_dt_visc, CS%diag) + !endif + !if (CS%id_hf_dv_dt_visc > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt_visc, CS%hf_dv_dt_visc, CS%diag) + !endif + if (CS%id_hf_du_dt_visc_2d > 0) then + allocate(hf_du_dt_visc_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_visc_2d(I,j) = hf_du_dt_visc_2d(I,j) + ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_visc_2d, hf_du_dt_visc_2d, CS%diag) + deallocate(hf_du_dt_visc_2d) + endif + if (CS%id_hf_dv_dt_visc_2d > 0) then + allocate(hf_dv_dt_visc_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_visc_2d(i,J) = hf_dv_dt_visc_2d(i,J) + ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_visc_2d, hf_dv_dt_visc_2d, CS%diag) + deallocate(hf_dv_dt_visc_2d) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -1760,6 +1806,40 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + 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) From 16a0a06566866cdf576320b0909841847a37430f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 29 Jul 2020 21:25:37 -0400 Subject: [PATCH 173/256] OBC: H-dimensionality fixes This patch fixes three dimensionality errors in the OBC segments. - We add a missing GV%m_to_H conversion for time-dependent eta segments. - The `adjustSegmentEtaToFitBathymetry` function depends on the `segment%Htot` field when computing the dz_src cell spacings. While the calculation primarily assumes that all quantities scale as Z, the segment%Htot field scales as H, which was causing dimensionality errors. We resolve this by converting Htot from Z to H whenever it is used in the calculation. - Segment barotropic velocitys based on transports were limited to a hard-coded thickness of 1e-12, which was not scaled. We have added H-dimensional scaling to these constants. --- src/core/MOM_open_boundary.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31f037c66e..35d559ab52 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3947,7 +3947,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dyCu(I,j) normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) enddo - segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) / (max(segment%Htot(I,j),1.e-12) * G%dyCu(I,j)) + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & + / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then @@ -3960,7 +3961,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dxCv(i,J) normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) enddo - segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) / (max(segment%Htot(i,J),1.e-12) * G%dxCv(i,J)) + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & @@ -4028,13 +4030,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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) + segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & + * segment%field(m)%buffer_dst(i,j,1) 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) + segment%eta(i,j) = GV%m_to_H * segment%field(m)%buffer_dst(i,j,1) enddo enddo endif @@ -4883,8 +4886,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j) + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j) + if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then + eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z contractions = contractions + 1 endif enddo @@ -4902,10 +4905,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < segment%Htot(i,j) - hTolerance) then + if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -segment%Htot(i,j) + eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo From 46714ecfc2a5e1a6d798758c300f10d8ae3899ca Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 30 Jul 2020 10:56:15 -0400 Subject: [PATCH 174/256] OBC: Removal of segment zero The current OBC segment list includes a "segment zero" which corresponds to when the segment maps (segnum_u, segnum_v) point to OBC_NONE, which is set to zero. The purpose of this "segment zero" seems to be for avoiding invalid references, so that OBC%segment(OBC%segnum_[uv](i,j)) always returns a valid result, included when set to OBC_NONE. This results in reading and setting values which are unused or unneeded. This patch replaces these redundant accesses to segment zero with various conditional blocks for avoiding these accesses. --- src/core/MOM_barotropic.F90 | 15 ++- src/core/MOM_continuity_PPM.F90 | 109 +++++++++++++----- src/core/MOM_isopycnal_slopes.F90 | 49 ++++---- src/core/MOM_open_boundary.F90 | 9 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 36 ++++-- .../vertical/MOM_set_diffusivity.F90 | 44 ++++--- 6 files changed, 178 insertions(+), 84 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7f34f18998..ae43868341 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -687,6 +687,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: ioff, joff + integer :: l_seg if (.not.associated(CS)) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") @@ -2324,9 +2325,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP parallel do default(shared) do j=js,je ; do I=is-1,ie - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then e_anom(i+1,j) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then e_anom(i,j) = e_anom(i+1,j) endif enddo ; enddo @@ -2335,9 +2339,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) do J=js-1,je ; do I=is,ie - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then e_anom(i,j+1) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then e_anom(i,j) = e_anom(i,j+1) endif enddo ; enddo diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c594d31494..995827959d 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -263,6 +263,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple type(OBC_segment_type), pointer :: segment => NULL() @@ -303,7 +304,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & +!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & +!$OMP any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do j=jsh,jeh do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -318,8 +320,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - uh(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif enddo endif enddo @@ -408,9 +414,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh + l_seg = OBC%segnum_u(I,j) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_u(I,j))%specified - do_I(I) = .not.(OBC%segnum_u(I,j) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh do_I(I) = .true. @@ -425,8 +435,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) + endif enddo ; endif enddo ; endif ! u-corrected @@ -438,9 +452,15 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified + l_seg = OBC%segnum_u(I,j) + + do_I(I) = .false. + if (l_seg /= OBC_NONE) & + do_I(I) = OBC%segment(l_seg)%specified + if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_u(I,j))%specified)) & @@ -529,6 +549,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ! with the same units as h_in. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -561,13 +582,17 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (local_open_BC) then do I=ish-1,ieh ; if (do_I(I)) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - uh(I) = G%dy_Cu(I,j) * u(I) * h(i) - duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) - else - uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) - duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = G%dy_Cu(I,j) * u(I) * h(i) + duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) + else + uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) + duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + endif endif endif endif ; enddo @@ -1062,6 +1087,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC type(OBC_segment_type), pointer :: segment => NULL() @@ -1103,7 +1129,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC ) & +!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do J=jsh-1,jeh do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -1118,8 +1144,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - vh(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif enddo endif enddo ! k-loop @@ -1204,9 +1234,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh + l_seg = OBC%segnum_v(i,J) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_v(i,J))%specified - do_I(i) = .not.(OBC%segnum_v(i,J) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh do_I(i) = .true. @@ -1221,8 +1255,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) & + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif enddo ; endif enddo ; endif ! v-corrected endif @@ -1233,9 +1271,15 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh - do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) + l_seg = OBC%segnum_v(i,J) + + do_I(I) = .false. + if(l_seg /= OBC_NONE) & + do_I(i) = (OBC%segment(l_seg)%specified) + if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_v(i,J))%specified)) & @@ -1327,6 +1371,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ! with the same units as h, i.e. [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1360,13 +1405,17 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) - else - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) + else + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + endif endif endif endif ; enddo diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 7a33dc7d77..c134366cd0 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -8,7 +8,7 @@ module MOM_isopycnal_slopes use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density_derivs -use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -105,6 +105,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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 + integer :: l_seg logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then @@ -183,7 +184,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio) + !$OMP drdx,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -260,15 +261,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - slope_x(I,j,K) = 0. - ! This and/or the masking code below is to make slopes match inside - ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then -! slope_x(I+1,j,K) = 0. -! else -! slope_x(I-1,j,K) = 0. -! endif + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif endif slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif @@ -286,7 +290,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio) + !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -360,15 +364,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - slope_y(i,J,K) = 0. - ! This and/or the masking code below is to make slopes match inside - ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then -! slope_y(i,J+1,K) = 0. -! else -! slope_y(i,J-1,K) = 0. -! endif + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif endif slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31f037c66e..b09cdc50c6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -445,9 +445,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) ! Allocate everything - ! Note the 0-segment is needed when %segnum_u/v(:,:) = 0 - allocate(OBC%segment(0:OBC%number_of_segments)) - do l=0,OBC%number_of_segments + allocate(OBC%segment(1:OBC%number_of_segments)) + do l=1,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. OBC%segment(l)%radiation_tan = .false. @@ -4971,7 +4970,7 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l = 0, OBC%number_of_segments + do l = 1, 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)) @@ -5168,7 +5167,7 @@ subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CSp, OBC) "If true, Temperature and salinity are used as state "//& "variables.", default=.true., do_not_log=.true.) - do l = 0, OBC%number_of_segments + do l = 1, OBC%number_of_segments call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) enddo diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e0def91821..9a0a994450 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -17,7 +17,7 @@ module MOM_lateral_mixing_coeffs use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init -use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE implicit none ; private @@ -499,6 +499,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) @@ -568,8 +569,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O CS%SN_u(I,j) = 0. endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - CS%SN_u(i,J) = 0. + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(i,J) = 0. + endif endif endif enddo @@ -609,8 +614,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O CS%SN_v(i,J) = 0. endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - CS%SN_v(i,J) = 0. + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif endif endif enddo @@ -657,6 +666,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) logical :: local_open_u_BC, local_open_v_BC @@ -754,8 +764,12 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_u(I,j) = 0.0 endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - CS%SN_u(I,j) = 0. + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(I,j) = 0. + endif endif endif enddo @@ -776,8 +790,12 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_v(I,j) = 0.0 endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(I,j))%open) then - CS%SN_v(I,j) = 0. + l_seg = OBC%segnum_v(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif endif endif enddo diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 86f828e5fa..42babae7d8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1677,7 +1677,9 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz + integer :: l_seg logical :: local_open_u_BC, local_open_v_BC + logical :: has_obc local_open_u_BC = .false. local_open_v_BC = .false. @@ -1718,15 +1720,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i,j+1,k) - endif + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + hvel = GV%H_to_Z*h(i,j,k) else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = GV%H_to_Z*h(i,j+1,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) @@ -1760,15 +1768,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i+1,j,k) - endif - else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + hvel = GV%H_to_Z*h(i,j,k) + else ! OBC_DIRECTION_W + hvel = GV%H_to_Z*h(i+1,j,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) From a243225b3e8a18b74b3ebbdc58ac80f231be2408 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 30 Jul 2020 15:14:26 -0400 Subject: [PATCH 175/256] OBC: Remove segment 0 refs in mask_outside_OBCs There were a few remaining segnum_[uv] references in MOM_open_boundary which could reference segment zero. This patch fixes those references. --- src/core/MOM_open_boundary.F90 | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b09cdc50c6..74cad3cf0c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4416,6 +4416,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + integer :: l_seg logical :: fatal_error = .False. real :: min_depth integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 @@ -4457,38 +4458,50 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif From 1daad4469b4bc63763546789b7cd8a57ef73e58e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:48:52 -0400 Subject: [PATCH 176/256] (*)Improve make_frazil Improve the handling of very thin layers in make_frazil. This does not change answers for typical values of ANGSTROM, but can avoid problems that can arise when ANGSTROM=0. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..ee9a7bacff 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -195,14 +195,14 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) endif hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) - if (h(i,j,k) <= 10.0*GV%Angstrom_H) then + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) tv%T(i,j,k) = T_freeze(i) endif - else - if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + 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 fraz_col(i) = 0.0 else From 948e2926f5c3288283266faf6bc5ca8d6bd25c3d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:50:03 -0400 Subject: [PATCH 177/256] (*)Improve advective CFL calculation with tiny h Improved handling of massless layers in the calculation of the advective CFL numbers used in PPM tracer advection by using an Adcroft reciprocal instead of adding a small value in the denominator. Although all answers are bitwise identical in the existing MOM6-examples test cases, this can avoid problems with tracer advection when ANGSTROM is 0 or very small like those that were recently found in analogous SIS2 code. --- src/tracer/MOM_tracer_advect.F90 | 104 ++++++++++++------------------- 1 file changed, 40 insertions(+), 64 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 6a362d4fd5..e9c8fb0e7b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -140,16 +140,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& !$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) -! This initializes the halos of uhr and vhr because pass_vector might do -! calculations on them, even though they are never used. -!$OMP do - + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do do k=1,nz do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo domore_k(k)=1 -! Put the remaining (total) thickness fluxes into uhr and vhr. + ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo if (.not. present(h_prev_opt)) then @@ -173,17 +172,17 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & enddo -!$OMP do + !$OMP do do j=jsd,jed ; do I=isd,ied-1 - uh_neglect(I,j) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=jsd,jed-1 ; do i=isd,ied - vh_neglect(i,J) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo -!$OMP do ! initialize diagnostic fluxes and tendencies + !$OMP do do m=1,ntr if (associated(Tr(m)%ad_x)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied @@ -207,7 +206,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo -!$OMP end parallel + !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -222,8 +221,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then -!$OMP parallel do default(none) shared(nz,domore_k,jsv,jev,domore_u,isv,iev,stencil, & -!$OMP uhr,domore_v,vhr) + !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then @@ -256,9 +254,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. -!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + !$OMP parallel default(shared) if (x_first) then @@ -305,7 +301,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & endif ! x_first -!$OMP end parallel + !$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -385,6 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. @@ -406,16 +403,15 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff -! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo do j=js,je ; if (domore_u(j,k)) then domore_u(j,k) = .false. - ! Calculate the i-direction profiles (slopes) of each tracer that - ! is being advected. + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then do m=1,ntr ; do i=is-stencil,ie+stencil !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & @@ -490,33 +486,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! in the cell plus whatever part of its half of the mass flux that ! the flux through the other side does not require. do I=is-1,ie - if (uhr(I,j,k) == 0.0) then + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then uhh(I) = 0.0 CFL(I) = 0.0 elseif (uhr(I,j,k) < 0.0) then hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h - hlos = MAX(0.0,uhr(I+1,j,k)) + hlos = MAX(0.0, uhr(I+1,j,k)) if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & ((0.5*hup + uhr(I,j,k)) < 0.0)) then - uhh(I) = MIN(-0.5*hup,-hup+hlos,0.0) + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) - CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-uhr(I-1,j,k)) + hlos = MAX(0.0, -uhr(I-1,j,k)) if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & ((0.5*hup - uhr(I,j,k)) < 0.0)) then - uhh(I) = MAX(0.5*hup,hup-hlos,0.0) + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive endif enddo @@ -545,11 +541,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR + aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL + aR = 3.*Tc - 2.*aL endif a6 = 6.*Tc - 3. * (aR + aL) ! Curvature @@ -570,28 +566,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m) flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i+1,m) flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -760,6 +745,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. @@ -777,8 +763,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff - !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, ! and updating tracer concentration within a cell @@ -822,7 +808,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! make a copy of the tracers in case values need to be overridden for OBCs - do j=G%jsd,G%jed; do m=1,ntr; do i=G%isd,G%ied + do j=G%jsd,G%jed ; do m=1,ntr ; do i=G%isd,G%ied T_tmp(i,m,j) = Tr(m)%t(i,j,k) enddo ; enddo ; enddo @@ -873,33 +859,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & domore_v(J,k) = .false. do i=is,ie - if (vhr(i,J,k) == 0.0) then + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then vhh(i,J) = 0.0 CFL(i) = 0.0 elseif (vhr(i,J,k) < 0.0) then hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h - hlos = MAX(0.0,vhr(i,J+1,k)) + hlos = MAX(0.0, vhr(i,J+1,k)) if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & ((0.5*hup + vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MIN(-0.5*hup,-hup+hlos,0.0) + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-vhr(i,J-1,k)) + hlos = MAX(0.0, -vhr(i,J-1,k)) if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & ((0.5*hup - vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MAX(0.5*hup,hup-hlos,0.0) + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive endif enddo @@ -952,26 +938,16 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) endif enddo ; enddo endif ! usePPM From cbbf84847384f2860bf8de765b5c1cb34687cb75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 15:02:28 -0400 Subject: [PATCH 178/256] Infrastructure calls via framework directory Revised module use statements and some infrastructure calls to go via the MOM6 framework directory rather than directly calling FMS infrastructure routines. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf.F90 | 1 - src/ice_shelf/MOM_ice_shelf_state.F90 | 1 - .../MOM_state_initialization.F90 | 20 ++++-------- src/tracer/MOM_generic_tracer.F90 | 32 +++++++++---------- src/tracer/MOM_offline_aux.F90 | 3 +- src/tracer/MOM_offline_main.F90 | 3 +- src/tracer/RGC_tracer.F90 | 5 ++- 8 files changed, 26 insertions(+), 43 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index a04ee426e6..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -9,10 +9,8 @@ module MOM_surface_forcing_gfdl use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6b68cb3deb..66fd873f67 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -51,7 +51,6 @@ module MOM_ice_shelf use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time implicit none ; private #include diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index b3e88697f2..a3784b5a34 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -12,7 +12,6 @@ module MOM_ice_shelf_state use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_get_input, only : directories, Get_MOM_input -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync use MOM_coms, only : reproducing_sum use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..a201e4a85f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -18,23 +18,17 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : file_exists -use MOM_io, only : MOM_read_data, MOM_read_vector -use MOM_io, only : slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data -use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments -use MOM_open_boundary, only : update_OBC_segment_data +use MOM_open_boundary, only : open_boundary_query, open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments, update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type @@ -44,8 +38,7 @@ module MOM_state_initialization use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain use MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity -use user_initialization, only : user_init_temperature_salinity -use user_initialization, only : user_set_OBC_data +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data @@ -97,7 +90,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 diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7d2310b42f..66c0e33bac 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -13,10 +13,8 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - ! ### These imports should not reach into FMS directly ### - use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE - use field_manager_mod, only: fm_get_index,fm_string_len + use field_manager_mod, only: fm_string_len use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag @@ -108,7 +106,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables logical :: register_MOM_generic_tracer - character(len=fm_string_len), parameter :: sub_name = 'register_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? @@ -122,7 +120,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call mpp_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") return endif @@ -185,7 +183,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -247,7 +245,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next @@ -265,7 +263,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, CS%diag=>diag !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -426,7 +424,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -443,7 +441,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -587,7 +585,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_stock' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -660,7 +658,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_min_max' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau @@ -728,7 +726,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) ! Local variables real :: sosga - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt type(g_tracer_type), pointer :: g_tracer @@ -750,7 +748,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -767,7 +765,7 @@ subroutine MOM_generic_flux_init(verbosity) integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out real :: const_init_value - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_flux_init' + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next if (.not. g_registered) then @@ -777,7 +775,7 @@ subroutine MOM_generic_flux_init(verbosity) call generic_tracer_get_list(g_tracer_list) if (.NOT. associated(g_tracer_list)) then - call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -812,7 +810,7 @@ subroutine MOM_generic_tracer_get(name,member,array, CS) type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. real, dimension(:,:,:), pointer :: array_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_get' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) array(:,:,:) = array_ptr(:,:,:) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 21db2cfff4..119ad555da 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,7 +4,6 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use data_override_mod, only : data_override_init, data_override use MOM_time_manager, only : time_type, operator(-) use MOM_debugging, only : check_column_integrals @@ -12,7 +11,7 @@ module MOM_offline_aux use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_verticalGrid, only : verticalGrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b7af9849b3..3895e8a116 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -4,7 +4,6 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -20,7 +19,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 028718f379..44c6c2e5a1 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -19,7 +19,7 @@ module RGC_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -207,8 +207,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%tracer_IC_file) do m=1,NTR call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") - call read_data(CS%tracer_IC_file, trim(name), & - CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else do m=1,NTR From 859abbd3641bd37484ccd423903784521f2c51c1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 3 Aug 2020 21:36:06 -0400 Subject: [PATCH 179/256] Add diagnostic of SGS T variance in Stanley PGF - Adds a diagnostic of the parameterized SGS T variance used in the Brankart correction to the PGF --- src/core/MOM_PressureForce_FV.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 6c01580e29..356bbea560 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -58,6 +58,7 @@ module MOM_PressureForce_FV !! the mean temperature gradient in the deterministic part of !! the Stanley form of the Brankart correction. integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_tvar_sgs = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -758,6 +759,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + if (CS%id_tvar_sgs>0) call post_data(CS%id_tvar_sgs, tv%varT, CS%diag) end subroutine PressureForce_FV_Bouss @@ -826,6 +828,10 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "the mean temperature gradient in the deterministic part of "// & "the Stanley form of the Brankart correction. "// & "Negative values disable the scheme.", units="nondim", default=-1.0) + if (CS%Stanley_T2_det_coeff>=0.) then + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs_pgf', diag%axesTL, & + Time, 'SGS temperature variance used in PGF', 'degC2') + endif 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) From f549dd01175d356008c5ad3bfb3eb61960eba5e5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 3 Aug 2020 21:37:38 -0400 Subject: [PATCH 180/256] Use thickness weighted variance estimate in PGF - The SGS T variance is measure from the grid-scale variance. It should be a horizontal difference but is approximated as along coordinate. This adds thickness weighting to avoid large values near topography. --- src/core/MOM_PressureForce_FV.F90 | 46 ++++++++++++++++++++++++------- 1 file changed, 36 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 356bbea560..fc2d40eaf3 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -480,7 +480,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 :: dTdi2, dTdj2 ! Differences in T variance [degC2] + !real :: dTdi2, dTdj2 ! Differences in T variance [degC2] + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stenil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencial of H [H ~> m] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -504,15 +506,39 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%Stanley_T2_det_coeff>=0.) then if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! SGS variance in i-direction [degC2] - dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 - ! SGS variance in j-direction [degC2] - dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 - tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + ! Strictly speaking we should be estimate the horizontal grid-scale variance + ! but neither of the following blocks make a rotation to the horizontal + ! but work along coordinate + + ! This block calculates a simple |delta T| along coordinates and does + ! not allow vanishing layer thicknesses or layers tracking topography + !! SGS variance in i-direction [degC2] + !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & + ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & + ! ) * G%dxT(i,j) * 0.5 )**2 + !! SGS variance in j-direction [degC2] + !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & + ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & + ! ) * G%dyT(i,j) * 0.5 )**2 + !tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + + ! This block does a thickness weighted variance calculation and helps control for + ! extreme gradients along layers which are vanished against topography. It is + ! still a poor approximation in the interior when coordinates are strongly tilted. + hl(1) = h(i,j,k) ; hl(2) = h(i-1,j,k) ; hl(3) = h(i+1,j,k) ; hl(4) = h(i,j-1,k) ; hl(5) = h(i,j+1,k) + mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff + mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + ! Mean of T + Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) ; Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + ! Adjust T vectors to have zero mean + Tl(:) = Tl(:) - mn_T ; mn_T = 0. + ! Variance of T + mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + ! Variance should be positive but round-off can violate this. Calculating + ! variance directly would fix this but requires more operations. + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2 - mn_T*mn_T) enddo ; enddo ; enddo endif From bba60af8efe150e65accdb2b2621614b707f8316 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 4 Aug 2020 12:06:41 -0400 Subject: [PATCH 181/256] Move call to initialize_segment_data to MOM_state_initialization --- src/core/MOM_open_boundary.F90 | 96 +++++++++++-------- .../MOM_state_initialization.F90 | 4 +- 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9b650f8598..f94060fc39 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -62,6 +62,7 @@ module MOM_open_boundary public update_OBC_ramp public rotate_OBC_config public rotate_OBC_init +public initialize_segment_data 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 @@ -268,7 +269,7 @@ module MOM_open_boundary 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(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: & rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of @@ -341,6 +342,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + character(len=128) :: inputdir + logical :: answers_2018, default_2018_answers + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=32) :: remappingScheme + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -497,7 +503,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - call initialize_segment_data(G, OBC, param_file) + ! call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & @@ -540,6 +546,46 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo + ! There is a problem with the order of the OBC initialization + ! with respect to ALE_init. Currently handling this by copying the + ! param file so that I can use it later in step_MOM in order to finish + ! initializing segments on the first step. + + ! Is the above comment still relevant ? + + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "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(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "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, answers_2018=answers_2018) + endif ! OBC%number_of_segments > 0 ! Safety check @@ -564,7 +610,7 @@ end subroutine open_boundary_config subroutine initialize_segment_data(G, OBC, PF) use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle @@ -576,10 +622,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - 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 @@ -599,39 +642,6 @@ subroutine initialize_segment_data(G, OBC, PF) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& - "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for "//& - "consistency and if non-monotonicity or an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for "//& - "conservation and new extrema and if an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "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, & - "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=.false.) - 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, answers_2018=answers_2018) - if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. @@ -4966,6 +4976,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) integer :: l + if (OBC_in%number_of_segments==0) return + ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments OBC%ke = OBC_in%ke @@ -5023,8 +5035,10 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) 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 + if (ASSOCIATED(OBC_in%remap_CS)) then + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + endif ! 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. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..f53ff89a1e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -24,7 +24,7 @@ module MOM_state_initialization use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h use MOM_open_boundary, only : fill_temp_salt_segments use MOM_open_boundary, only : update_OBC_segment_data @@ -563,6 +563,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then + call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) +! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values if (.not. OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) From 7be08832127b4669db8644cfc261ba82163d3a5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:03 -0400 Subject: [PATCH 182/256] (*)Set dSV_dT and dSV_dS with unassociated fluxes Set dSV_dT and dSV_dS if present in applyBoundaryFluxesInOut, even if boundary fluxes are not associated. With this change, setting BUOY_CONFIG='NONE' and BUOY_CONFIG='zero' both work and give similar (but not identical) answers in some test cases with an ePBL boundary layer parameterization, whereas before answers were tainted with uninitialized values when BUOY_CONFIG='NONE'. All answers in the existing MOM6-examples test suite are bitwise identical, but answers can change in other cases. --- .../vertical/MOM_diabatic_aux.F90 | 15 +++++++++------ .../vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..bf2e86cb80 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -822,19 +822,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - ! Only apply forcing if fluxes%sw is associated. - if (.not.associated(fluxes%sw)) return - -#define _OLD_ALG_ Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 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 + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + if (calculate_buoyancy) then SurfPressure(:) = 0.0 GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 @@ -874,7 +873,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d(i,k) = h(i,j,k) T2d(i,k) = tv%T(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) if (calculate_energetics) then ! The partial derivatives of specific volume with temperature and @@ -898,6 +896,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pen_TKE_2d(:,:) = 0.0 endif + ! Nothing more is done on this j-slice if there is no buoyancy forcing. + if (.not.associated(fluxes%sw)) cycle + + if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c6a6f37b39..1a4fb58e02 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1143,12 +1143,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, 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 :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz - real :: botfn a_cpl(:,:) = 0.0 Kv_tot(:,:) = 0.0 From feed9ba82b9ebe6805ce691e77190b2f5ba4f7ee Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:40 -0400 Subject: [PATCH 183/256] (*)Fix an indexing bug in int_density_dz_linear Corrected a horizontal indexing bug in int_density_dz_linear that caused the ISOMIP/layer test case to fail. This bug was first introduced with PR#732 on March 8, 2018. This bug fix will change answers with a linear equation of state and the finite volume pressure gradient force, however it does not change any of the verified answers in the MOM6-examples regression suite. --- src/equation_of_state/MOM_EOS_linear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e3a5443840..47a2bf21b0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -473,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & 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,j) ; intz(5) = dpa(i+1,j) + 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 From 3c10ae18a72b3096ea69b81dc3906931eefa9a6f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 10 Aug 2020 10:46:31 -0400 Subject: [PATCH 184/256] Remove outdated comments --- src/core/MOM_open_boundary.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f94060fc39..37ebeda1fa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -546,13 +546,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo - ! There is a problem with the order of the OBC initialization - ! with respect to ALE_init. Currently handling this by copying the - ! param file so that I can use it later in step_MOM in order to finish - ! initializing segments on the first step. - - ! Is the above comment still relevant ? - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& From f4281ed2f8d61698d1884f9bfaa6550c9f1423cd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 13 Aug 2020 13:06:08 -0400 Subject: [PATCH 185/256] +Move find_interfaces to MOM_state_initialization Simplified and cleaned up find_interfaces and moved it from MOM_tracer_Z_init to MOM_state_initialization, reflecting the fact that it is only used from within MOM_state_initialization and that it has very little to do with tracer initialization. The subroutine fast_bisect was inlined into find_interfaces and the stand-alone version was deleted. One minor bug that could change answers was noted but not corrected. All answers are bitwise identical, but the previously publicly visible interface to find_interfaces was made private to the MOM_state_initialization module. --- .../MOM_state_initialization.F90 | 110 ++++++++++- src/tracer/MOM_tracer_Z_init.F90 | 179 +----------------- 2 files changed, 110 insertions(+), 179 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b613648c7c..9f505325bf 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -84,7 +84,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 MOM_tracer_Z_init, only : find_interfaces, tracer_Z_init_array, determine_temperature +use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated use MOM_ALE, only : TS_PLM_edge_values @@ -2422,6 +2422,114 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param end subroutine MOM_temp_salt_initialize_from_Z + +!> Find interface positions corresponding to interpolated depths in a density profile +subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, hml, & + 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)), & + intent(in) :: nlevs !< number of valid points in each column + integer, intent(in) :: nkml !< number of mixed layer pieces to distribute over + !! a depth of hml. + real, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. + real, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. + + ! Local variables + real, dimension(nk_data) :: rho_ ! A column of densities [R ~> kg m-3] + real, dimension(SZK_(G)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. + real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] + real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] + real, parameter :: zoff=0.999 + logical :: unstable ! True if the column is statically unstable anywhere. + integer :: nlevs_data ! The number of data values in a column. + logical :: work_down ! This indicates whether this pass goes up or down the water column. + integer :: k_int, lo_int, hi_int, mid + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + zi(:,:,:) = 0.0 + + do j=js,je ; do i=is,ie + nlevs_data = nlevs(i,j) + do k=1,nlevs_data ; rho_(k) = rho(i,j,k) ; enddo + + unstable=.true. + work_down = .true. + do while (unstable) + ! Modifiy the input profile until it no longer has densities that decrease with depth. + unstable=.false. + if (work_down) then + do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0 ) then + if (k == 2) then + rho_(k-1) = rho_(k) - eps_rho + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(k) = rho_(k-1) + drhodz*zoff*(zin(k)-zin(k-1)) + endif + endif ; enddo + work_down = .false. + else + do k=nlevs_data-1,2,-1 ; if (rho_(k+1) - rho_(k) < 0.0) then + if (k == nlevs_data-1) then + rho_(k+1) = rho_(k-1) + eps_rho !### This should be rho_(k) + eps_rho + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(k) = rho_(k+1) - drhodz*(zin(k+1)-zin(k)) + endif + endif ; enddo + work_down = .true. + endif + enddo + + ! Find and store the interface depths. + zi_(1) = 0.0 + do K=2,nz + ! Find the value of k_int in the list of rho_ where rho_(k_int) <= Rb(K) < rho_(k_int+1). + ! This might be made a little faster by exploiting the fact that Rb is + ! monotonically increasing and not resetting lo_int back to 1 inside the K loop. + lo_int = 1 ; hi_int = nlevs_data + do while (lo_int < hi_int) + mid = (lo_int+hi_int) / 2 + if (Rb(K) < rho_(mid)) then ; hi_int = mid + else ; lo_int = mid+1 ; endif + enddo + k_int = max(1, lo_int-1) + + ! Linearly interpolate to find the depth, zi_, where Rb would be found. + slope = (zin(k_int+1) - zin(k_int)) / max(rho_(k_int+1) - rho_(k_int), eps_rho) + zi_(K) = -1.0*(zin(k_int) + slope*(Rb(K)-rho_(k_int))) + zi_(K) = min(max(zi_(K), -depth(i,j)), -1.0*hml) + enddo + zi_(nz+1) = -depth(i,j) + if (nkml > 0) then ; do K=2,nkml+1 + zi_(K) = max(hml*((1.0-real(K))/real(nkml)), -depth(i,j)) + enddo ; endif + do K=nz,max(nkml+2,2),-1 + if (zi_(K) < zi_(K+1) + eps_Z) zi_(K) = zi_(K+1) + eps_Z + if (zi_(K) > -1.0*hml) zi_(K) = max(-1.0*hml, -depth(i,j)) + enddo + + do K=1,nz+1 + zi(i,j,K) = zi_(K) + enddo + enddo ; enddo ! i- and j- loops + +end subroutine find_interfaces + !> Run simple unit tests subroutine MOM_state_init_tests(G, GV, US, tv) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 401bf82a2b..ac6242785e 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -16,7 +16,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init, tracer_Z_init_array, find_interfaces, determine_temperature +public tracer_Z_init, tracer_Z_init_array, 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 @@ -608,135 +608,6 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope -!> Find interface positions corresponding to density profile -subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, 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 to distribute over - !! a depth of hml. - 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(SZI_(G),nk_data) :: rho_ ! A slice of densities [R ~> kg m-3] - logical :: unstable - integer :: dir - integer, dimension(SZI_(G),SZK_(G)+1) :: ki_ - real, dimension(SZI_(G),SZK_(G)+1) :: zi_ ! A slice of interface heights (negative downward) [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs_data - integer, dimension(SZI_(G)) :: lo, hi - real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] - real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] - real :: hml_ ! The depth of the mixed layer to use for the topmost nkml_ layers [Z ~> m]. - real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. - real :: epsln_rho ! A negligibly small density change [R ~> kg m-3]. - real, parameter :: zoff=0.999 - integer :: nkml_ - logical :: debug_ = .false. - integer :: i, j, k, m, n, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - zi(:,:,:) = 0.0 - - if (PRESENT(debug)) debug_=debug - - nlevs_data(:,:) = nz - - nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) - hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml - 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=js,je - rho_(:,:) = rho(:,j,:) - 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,:) - 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 - lo(:) = 1 - hi(:) = nlevs_data(:,j) - ki_ = bisect_fast(rho_, Rb, lo, hi) - ki_(:,:) = max(1, ki_(:,:)-1) - 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,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 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 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_tgt, p_ref, niter, land_fill, h, k_start, G, US, eos, h_massless) @@ -855,52 +726,4 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, 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 f147071032e8255a8d8c243f26ce07054c092ee3 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 14 Aug 2020 15:37:22 -0400 Subject: [PATCH 186/256] New option to use a grid index convention for spatially-varying diagnostics. --- src/framework/MOM_diag_mediator.F90 | 80 ++++++++++++++++++++++++----- 1 file changed, 66 insertions(+), 14 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 2a71e7cda5..28c4c867d7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -243,7 +243,7 @@ module MOM_diag_mediator integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics - + logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. ! The following fields are used for the output of the data. integer :: is !< The start i-index of cell centers within the computational domain integer :: ie !< The end i-index of cell centers within the computational domain @@ -359,25 +359,71 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert + real, allocatable, dimension(:) :: IaxB,iax + real, allocatable, dimension(:) :: JaxB,jax + set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical + + if (diag_cs%grid_space_axes) then + allocate(IaxB(G%IsgB:G%IegB)) + do i=G%IsgB, G%IegB + Iaxb(i)=real(i) + enddo + allocate(iax(G%isg:G%ieg)) + do i=G%isg, G%ieg + iax(i)=real(i)-0.5 + enddo + allocate(JaxB(G%JsgB:G%JegB)) + do j=G%JsgB, G%JegB + JaxB(j)=real(j) + enddo + allocate(jax(G%jsg:G%jeg)) + do j=G%jsg, G%jeg + jax(j)=real(j)-0.5 + enddo + endif + ! Horizontal axes for the native grids if (G%symmetric) then - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif else - id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif + endif + + + if (diag_cs%grid_space_axes) then + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'h point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain) endif - id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) if (set_vert) then nz = GV%ke @@ -531,6 +577,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif enddo + if (diag_cs%grid_space_axes) then + deallocate(IaxB,iax,JaxB,jax) + endif !Define the downsampled axes call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) @@ -3037,6 +3086,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) "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, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & + 'If true, use a grid index coordinate convention for diagnostic axes. ',& + default=.false.) + 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* @@ -4264,4 +4317,3 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ end subroutine downsample_mask_3d end module MOM_diag_mediator - From fefa30e7fc04fd00fa40a8fc03ac69597d4354f3 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 17 Aug 2020 12:03:28 -0400 Subject: [PATCH 187/256] Tests tc0 diagnostic axes in grid space. --- .testing/tc0/MOM_input | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index be1cae0908..ff64c55803 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -138,6 +138,9 @@ THICKNESS_CONFIG = "uniform" ! ! === module MOM_diag_mediator === +USE_GRID_SPACE_DIAG_COORDINATE_AXES = True ! [Boolean] default = False + ! If true, use a grid index coordinate convention for diagnostic axes. + ! === module MOM_MEKE === ! === module MOM_lateral_mixing_coeffs === From 13d74a4f6b424a47cd23eeac43bd3bd67a7f29f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 17 Aug 2020 17:47:34 -0400 Subject: [PATCH 188/256] (*)Revised the routine wave_speeds Revised wave_speeds to agree with the calculation of the first mode wave speed in wave_speed, and to also avoid returning speeds that report back uninitialized values that do not reproduce across processor layouts and are not dimensionally consistent. With these revisions, the diagnosed speeds of the modes reproduce other solutions, reproduce across layouts, are of sensible magnitude and are demonstrably dimensionally consistent. This includes a complete rewrite of tridiag_det, which previously was just wrong. Also revised the calls to register_diag_field for the cn1 and cn_mode# diagnostics to include conversion factors. All existing MOM6-examples solutions are bitwise identical, although there would be answer changes in cases where the wave speeds are used in active parameterizations. --- src/diagnostics/MOM_wave_speed.F90 | 172 ++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 5 +- 2 files changed, 77 insertions(+), 100 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index b3321cdace..00a5c1f4a8 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -686,6 +686,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee !! 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] @@ -696,23 +697,22 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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 - ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. - real, dimension(SZK_(G)-1) :: & - a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & + Igl, Igu, & ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] 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, dimension(SZK_(G)-1) :: & + a_diag, b_diag, c_diag + ! diagonals of tridiagonal matrix; one value for each + ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] 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] @@ -722,7 +722,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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] - real :: dlam ! increment in lam for Newton's method [T2 L-2 ~> s2 m-2] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] @@ -735,7 +735,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] 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_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] @@ -747,13 +746,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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] + ! A 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 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]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of ! the total water column can be merged for efficiency. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. 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] @@ -762,8 +762,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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 integer, parameter :: sub_it_max = 4 ! maximum number of times to subdivide interval @@ -786,9 +784,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 - use_EOS = associated(tv%eqn_of_state) ! 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) 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. @@ -799,11 +797,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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 + tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; 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 + ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified + ! are not changed from this zero value. + cn(:,:,:) = 0.0 + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & @@ -922,9 +924,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! 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 + if (g_Rho0 * drxh_sum > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. @@ -995,7 +995,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! far back we go. do k2=kc,2,-1 if (better_est) then - merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(kc) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + 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 @@ -1019,12 +1019,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- - ig = i + G%idg_offset ; jg = j + G%jdg_offset + ! ig = i + G%idg_offset ; jg = j + G%jdg_offset ! Sum the contributions from all of the interfaces to give an over-estimate - ! of the first-mode wave speed. + ! of the first-mode wave speed. Also populate Igl and Igu which are the + ! non-leading diagonals of the tridiagonal matrix. if (kc >= 2) then - ! Set depth at surface - z_int(1) = 0.0 ! initialize speed2_tot speed2_tot = 0.0 if (better_est) then @@ -1038,41 +1037,25 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! [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))) 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) - ! Calculate depth at bottom - z_int(kc+1) = z_int(kc)+Hc(kc) - ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i)) > 1.e-12*htot(i)) then - call MOM_error(FATAL, "wave_structure: mismatch in total depths") - endif - ! Define the diagonals of the tridiagonal matrix - ! First, populate interior rows - do K=3,kc-1 - row = K-1 ! indexing for TD matrix rows - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) + ! Define the diagonals of the tridiagonal matrix for use by tridiag_det + a_diag(1) = 0.0 + b_diag(1) = Igu(2)+Igl(2) + c_diag(1) = -Igl(2) + do k=2,kc-2 + a_diag(k) = -Igu(k+1) + b_diag(k) = Igu(k+1)+Igl(k+1) + c_diag(k) = -Igl(k+1) enddo - ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 - a_diag(row) = 0.0 - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) - ! Populate bottom row of tridiagonal matrix - K=kc ; row = K-1 - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = 0.0 + a_diag(kc-1) = -Igu(kc) + b_diag(kc-1) = Igu(kc)+Igl(kc) + c_diag(kc-1) = 0.0 ! Total number of rows in the matrix = number of interior interfaces nrows = kc-1 @@ -1082,26 +1065,26 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! 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=c2_scale) - ! Use Newton's method iteration to find a new estimate of lam_1 + call tridiag_det(a_diag(1:nrows), b_diag(1:nrows), c_diag(1:nrows), & + nrows, lam_1, det, ddet, row_scale=c2_scale) + + ! If possible, 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 ! lam_1 was not an under-estimate, as intended, so Newton's method - ! may not be reliable; lam_1 must be reduced, but not by more - ! than half. + ! may not be reliable; lam_1 must be reduced, but not by more than half. lam_1 = 0.5 * lam_1 + dlam = -lam_1 else ! Newton's method is OK. dlam = - det / ddet lam_1 = lam_1 + dlam - 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 - endif endif + + if (abs(dlam) < tol_solve*lam_1) exit enddo + if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + ! 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 @@ -1177,7 +1160,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee elseif (iint == numint) then ! oops, lamMax not large enough - could add code to increase (BDM) ! set unfound modes to zero for now (BDM) - cn(i,j,nrootsfound+2:nmodes) = 0.0 + ! cn(i,j,nrootsfound+2:nmodes) = 0.0 else ! else shift interval and keep looking until nmodes or numint is reached det_l = det_r @@ -1195,22 +1178,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam - 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 - endif ! within tol + if (abs(dlam) < tol_solve*lam_1) exit enddo ! itt-loop + ! calculate nth mode speed + if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) enddo ! n-loop - else - cn(i,j,2:nmodes) = 0.0 ! else too small to worry about endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh - else - cn(i,j,:) = 0.0 endif ! if more than 2 layers endif ! if drxh_sum < 0 - else - cn(i,j,:) = 0.0 ! This is a land point. endif ! if not land enddo ! i-loop enddo ! j-loop @@ -1221,47 +1196,50 @@ end subroutine wave_speeds !! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. -subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) - real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry = 0) - real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) - real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry = 0) +subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) + real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) integer, intent(in) :: nrows !< Size of matrix - real, intent(in) :: lam !< Value subtracted from b - real, intent(out):: det_out !< Determinant - real, intent(out):: ddet_out !< Derivative of determinant w.r.t. lam + real, intent(in) :: lam !< Value subtracted from b + real, intent(out):: det !< Determinant + real, intent(out):: ddet !< Derivative of determinant with lam real, optional, intent(in) :: row_scale !< A scaling factor of the rows of the !! matrix to limit the growth of the determinant ! Local variables - real, dimension(nrows) :: det ! value of recursion function - real, dimension(nrows) :: ddet ! value of recursion function for derivative + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers. + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two layers. real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling - real :: rscl + real :: rscl ! A rescaling factor that is applied succesively to each row. real :: I_rescale ! inverse of rescale - integer :: n ! row (layer interface) index + integer :: k ! row (layer interface) index if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") - I_rescale = 1.0/rescale + I_rescale = 1.0 / rescale rscl = 1.0 ; if (present(row_scale)) rscl = row_scale - det(1) = 1.0 ; ddet(1) = 0.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) - ! Rescale det & ddet if det is getting too large or too small to avoid overflow or underflow. - if (abs(det(n)) > rescale) then - det(n) = I_rescale*det(n) ; det(n-1) = I_rescale*det(n-1) - ddet(n) = I_rescale*ddet(n) ; ddet(n-1) = I_rescale*ddet(n-1) - elseif (abs(det(n)) < I_rescale) then - det(n) = rescale*det(n) ; det(n-1) = rescale*det(n-1) - ddet(n) = rescale*ddet(n) ; ddet(n-1) = rescale*ddet(n-1) + detKm1 = 1.0 ; ddetKm1 = 0.0 + det = (b(1) - lam) ; ddet = -1.0 + do k=2,nrows + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = row_scale*detKm1 ; ddetKm2 = row_scale*ddetKm1 + detKm1 = row_scale*det ; ddetKm1 = row_scale*ddet + + det = (b(k)-lam)*detKm1 - (a(k)*c(k-1))*detKm2 + ddet = (b(k)-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 + + ! Rescale det & ddet if det is getting too large or too small. + if (abs(det) > rescale) then + det = I_rescale*det ; detKm1 = I_rescale*detKm1 + ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 + elseif (abs(det) < I_rescale) then + det = rescale*det ; detKm1 = rescale*detKm1 + ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 endif enddo - det_out = det(nrows) - ddet_out = ddet(nrows) / rscl end subroutine tridiag_det diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7c24b774b3..8f3aef32c9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -352,7 +352,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! associated(tv%T) .AND. associated(tv%frazil) if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G, GV, US) - if (CS%use_int_tides) then ! This block provides an interface for the unresolved low-mode internal tide module (BDM). call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & @@ -3379,13 +3378,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1') + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) allocate(CS%id_cn(CS%nMode)) ; CS%id_cn(:) = -1 do m=1,CS%nMode write(var_name, '("cn_mode",i1)') m write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & - Time, var_descript, 'm s-1') + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) enddo endif From 74614b5887cd984a760a5fd916775d66e47942d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Aug 2020 12:08:07 -0400 Subject: [PATCH 189/256] Use similar routines in wave_speed and wave_speeds Revised both wave_speed and wave_speeds to use the same tridiag_det routine to estimate the determinant and its derivative for their Newton's method solver, making it more obvious where these two functions are using the same techniques. In turn, tridiag_deg was modified to take arguments that exploit the fact that only the upper and lower diagonals plus the candidate eigenvalue are needed in the specific case used here, avoiding the need for extra arrays and array copies. The internal routine tdma6 was also modified to expand similar expressions relating the center, upper and lower diagonals, and switching the sign convention in the diagonal arguments to avoid extra copies. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 152 +++++++++-------------------- 1 file changed, 47 insertions(+), 105 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 00a5c1f4a8..8b50fe1acb 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -94,9 +94,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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 - ! the thickness of the layer below (Igl) or above (Igu) it. - ! Their sum, Igd, is provided for the tridiagonal solver. [T2 L-2 ~> s2 m-2] + Igl, Igu ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -211,7 +210,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !$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,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 Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & !$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & !$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) @@ -493,57 +492,27 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ do itt=1,max_itt lam_it(itt) = lam if (l_use_ebt_mode) then - ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows - ! of the matrix are + ! This initialization of det,ddet imply Neumann boundary conditions for horizontal + ! velocity or pressure modes, so that first 3 rows of the matrix are ! / b(1)-lam igl(1) 0 0 0 ... \ ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | - ! which is consistent if the eigenvalue problem is for horizontal velocity or pressure modes. - !detKm1 = c2_scale*(Igl(1)-lam) ; ddetKm1 = -1.0*c2_scale - !det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1)) ; ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - detKm1 - detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igl(1)-lam) ; ddet = -1.0 - if (kc>1) then - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1))*detKm2 - ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - (Igu(2)*Igl(1))*ddetKm2 - detKm1 - endif ! The last two rows of the pressure equation matrix are ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 1, kc, lam, det, ddet, row_scale=c2_scale) else - ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows - ! of the matrix are + ! This initialization of det,ddet imply Dirichlet boundary conditions for vertical + ! velocity modes, so that first 3 rows of the matrix are ! / b(2)-lam igl(2) 0 0 0 ... | ! | igu(3) b(3)-lam igl(3) 0 0 ... | ! | 0 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 ! The last three rows of the w equation matrix are - ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) 0 | + ! | ... 0 igu(kc-2) b(kc-2)-lam igl(kc-2) 0 | ! | ... 0 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 2, kc, lam, det, ddet, row_scale=c2_scale) endif - do k=3,kc - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - - det = (Igu(k)+Igl(k)-lam)*detKm1 - (Igu(k)*Igl(k-1))*detKm2 - ddet = (Igu(k)+Igl(k)-lam)*ddetKm1 - (Igu(k)*Igl(k-1))*ddetKm2 - detKm1 - - ! Rescale det & ddet if det is getting too large or too small. - if (abs(det) > rescale) then - det = I_rescale*det ; detKm1 = I_rescale*detKm1 - ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 - elseif (abs(det) < I_rescale) then - det = rescale*det ; detKm1 = rescale*detKm1 - ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 - endif - enddo ! Use Newton's method iteration to find a new estimate of lam. det_it(itt) = det ; ddet_it(itt) = ddet @@ -559,10 +528,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif if (calc_modal_structure) then - do k = 1,kc - Igd(k) = Igu(k) + Igl(k) - enddo - call tdma6(kc, -Igu, Igd, -Igl, lam, mode_struct) + call tdma6(kc, Igu, Igl, lam, mode_struct) ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -620,51 +586,54 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ end subroutine wave_speed -!> Solve a non-symmetric tridiagonal problem with a scalar contribution to the leading diagonal. +!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagnonals minus a +!! scalar contribution as the leading diagonal. !! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. -subroutine tdma6(n, a, b, c, lam, y) +subroutine tdma6(n, a, c, lam, y) integer, intent(in) :: n !< Number of rows of matrix - real, dimension(n), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: b !< Leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(inout) :: y !< RHS on entry, result on exit + real, dimension(:), intent(inout) :: y !< RHS on entry, result on exit + ! Local variables - integer :: k, l - real :: beta(n), lambda ! Temporary variables in [T2 L-2 ~> s2 m-2] - real :: I_beta(n) ! Temporary variables in [L2 T-2 ~> m2 s-2] - real :: yy(n) ! A temporary variable with the same units as y on entry. + real :: lambda ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: beta(n) ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: I_beta(n) ! A temporary variable in [L2 T-2 ~> m2 s-2] + real :: yy(n) ! A temporary variable with the same units as y on entry. + integer :: k, m lambda = lam - beta(1) = b(1) - lambda + beta(1) = (a(1)+c(1)) - lambda if (beta(1)==0.) then ! lam was chosen too perfectly ! Change lambda and redo this first row lambda = (1. + 1.e-5) * lambda - beta(1) = b(1) - lambda + beta(1) = (a(1)+c(1)) - lambda endif I_beta(1) = 1. / beta(1) yy(1) = y(1) do k = 2, n - beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + beta(k) = ( (a(k)+c(k)) - lambda ) - a(k) * c(k-1) * I_beta(k-1) ! Perhaps the following 0 needs to become a tolerance to handle underflow? if (beta(k)==0.) then ! lam was chosen too perfectly ! Change lambda and redo everything up to row k lambda = (1. + 1.e-5) * lambda - I_beta(1) = 1. / ( b(1) - lambda ) - do l = 2, k - I_beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * I_beta(l-1) ) - yy(l) = y(l) - a(l) * yy(l-1) * I_beta(l-1) + I_beta(1) = 1. / ( (a(1)+c(1)) - lambda ) + do m = 2, k + I_beta(m) = 1. / ( ( (a(m)+c(m)) - lambda ) - a(m) * c(m-1) * I_beta(m-1) ) + yy(m) = y(m) + a(m) * yy(m-1) * I_beta(m-1) enddo else I_beta(k) = 1. / beta(k) endif - yy(k) = y(k) - a(k) * yy(k-1) * I_beta(k-1) + yy(k) = y(k) + a(k) * yy(k-1) * I_beta(k-1) enddo ! The units of y change by a factor of [L2 T-2] in the following lines. y(n) = yy(n) * I_beta(n) do k = n-1, 1, -1 - y(k) = ( yy(k) - c(k) * y(k+1) ) * I_beta(k) + y(k) = ( yy(k) + c(k) * y(k+1) ) * I_beta(k) enddo + end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. @@ -709,10 +678,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee 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, dimension(SZK_(G)-1) :: & - a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] 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] @@ -768,7 +733,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! for root finding (# intervals = 2**sub_it_max) logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging - integer :: nrows, sub, sub_it + integer :: 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 @@ -1044,29 +1009,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee endif enddo - ! Define the diagonals of the tridiagonal matrix for use by tridiag_det - a_diag(1) = 0.0 - b_diag(1) = Igu(2)+Igl(2) - c_diag(1) = -Igl(2) - do k=2,kc-2 - a_diag(k) = -Igu(k+1) - b_diag(k) = Igu(k+1)+Igl(k+1) - c_diag(k) = -Igl(k+1) - enddo - a_diag(kc-1) = -Igu(kc) - b_diag(kc-1) = Igu(kc)+Igl(kc) - c_diag(kc-1) = 0.0 - ! Total number of rows in the matrix = number of interior interfaces - nrows = kc-1 - ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot ! 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=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, lam_1, det, ddet, row_scale=c2_scale) ! If possible, use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) @@ -1103,14 +1052,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! that are beyond the first root ! 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=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, 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=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, 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 @@ -1130,8 +1077,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! loop over each subinterval: 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=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, 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. @@ -1173,8 +1120,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee lam_n = xbl(m) ! first guess is left edge of window 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=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, 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 @@ -1196,11 +1142,11 @@ end subroutine wave_speeds !! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. -subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) +subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) - real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) - integer, intent(in) :: nrows !< Size of matrix + integer, intent(in) :: ks !< Starting index to use in determinant + integer, intent(in) :: ke !< Ending index to use in determinant real, intent(in) :: lam !< Value subtracted from b real, intent(out):: det !< Determinant real, intent(out):: ddet !< Derivative of determinant with lam @@ -1214,22 +1160,18 @@ subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) real :: I_rescale ! inverse of rescale integer :: k ! row (layer interface) index - if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") - I_rescale = 1.0 / rescale rscl = 1.0 ; if (present(row_scale)) rscl = row_scale detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (b(1) - lam) ; ddet = -1.0 - do k=2,nrows + det = (a(ks)+c(ks)) - lam ; ddet = -1.0 + do k=ks+1,ke ! Shift variables and rescale rows to avoid over- or underflow. detKm2 = row_scale*detKm1 ; ddetKm2 = row_scale*ddetKm1 detKm1 = row_scale*det ; ddetKm1 = row_scale*ddet - det = (b(k)-lam)*detKm1 - (a(k)*c(k-1))*detKm2 - ddet = (b(k)-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 + det = ((a(k)+c(k))-lam)*detKm1 - (a(k)*c(k-1))*detKm2 + ddet = ((a(k)+c(k))-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 ! Rescale det & ddet if det is getting too large or too small. if (abs(det) > rescale) then From db74a47b0e6b3af6c75ece2c07bcee197b68dbbb Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 19 Aug 2020 14:40:59 -0400 Subject: [PATCH 190/256] fix bugs in wave_structure * inconsistent sizes in array copies * test on number of layers * allow to run without internal_tides input file --- src/diagnostics/MOM_wave_structure.F90 | 18 +++++++-------- .../lateral/MOM_internal_tides.F90 | 22 ++++++++++++------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 632a68e0ce..e2de3881ad 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -378,7 +378,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Also, note that "K" refers to an interface, while "k" refers to the layer below. ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also ! need number of layers to be greater than the mode number - if (kc >= ModeNum + 1) then + if (kc > ModeNum + 1) then ! Set depth at surface z_int(1) = 0.0 ! Calculate Igu, Igl, depth, and N2 at each interior interface @@ -485,8 +485,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Calculate terms in vertically integrated energy equation int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(:) = u_strct(1:nzm)**2 - w_strct2(:) = w_strct(1:nzm)**2 + u_strct2(1:nzm) = u_strct(1:nzm)**2 + w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) @@ -518,12 +518,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(:) - CS%u_strct(i,j,1:nzm) = u_strct(:) - CS%W_profile(i,j,1:nzm) = W_profile(:) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) - CS%N2(i,j,1:nzm) = N2(:) + CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) + CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) + CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else ! If not enough layers, default to zero diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a0f1631d6d..c327d1cece 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -15,7 +15,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -2324,12 +2324,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & + G%domain, timelevel=1) + endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle @@ -2339,11 +2341,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed partial reflection coefficients from file call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & "The path to the file containing the reflection coefficients.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2362,11 +2366,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & "The path to the file containing the double-reflective ridge tags.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. do i=isd,ied; do j=jsd,jed From 7a0dc2a056ed6aa230ce741f7bfbd6f5ec1c642d Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 19 Aug 2020 14:40:59 -0400 Subject: [PATCH 191/256] fix bugs in wave_structure * inconsistent sizes in array copies * test on number of layers * allow to run without internal_tides input file --- src/diagnostics/MOM_wave_structure.F90 | 18 +++++++-------- .../lateral/MOM_internal_tides.F90 | 22 ++++++++++++------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 632a68e0ce..88b062472f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -378,7 +378,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Also, note that "K" refers to an interface, while "k" refers to the layer below. ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also ! need number of layers to be greater than the mode number - if (kc >= ModeNum + 1) then + if (kc >= max(3, ModeNum + 1)) then ! Set depth at surface z_int(1) = 0.0 ! Calculate Igu, Igl, depth, and N2 at each interior interface @@ -485,8 +485,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Calculate terms in vertically integrated energy equation int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(:) = u_strct(1:nzm)**2 - w_strct2(:) = w_strct(1:nzm)**2 + u_strct2(1:nzm) = u_strct(1:nzm)**2 + w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) @@ -518,12 +518,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(:) - CS%u_strct(i,j,1:nzm) = u_strct(:) - CS%W_profile(i,j,1:nzm) = W_profile(:) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) - CS%N2(i,j,1:nzm) = N2(:) + CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) + CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) + CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else ! If not enough layers, default to zero diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a0f1631d6d..c327d1cece 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -15,7 +15,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -2324,12 +2324,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & + G%domain, timelevel=1) + endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle @@ -2339,11 +2341,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed partial reflection coefficients from file call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & "The path to the file containing the reflection coefficients.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2362,11 +2366,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & "The path to the file containing the double-reflective ridge tags.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. do i=isd,ied; do j=jsd,jed From e8b5d96bcb769b79f68a671e35f4f02940d7cab5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 Aug 2020 18:47:35 -0400 Subject: [PATCH 192/256] *+Add halo updates needed with VERTEX_SHEAR=True Made a set of changes to add halo updates that are needed to reproduce answers across PE layouts or for reentrant cases with USE_JACKSON_PARAM=True and VERTEX_SHEAR=True. The changes include: 1. Add halo updates for T & S after advection if needed. 2. Add new optional argument to extract_diabatic_member to return the valid temperature, salinity, p_surf and thickness halos that are required upon entry to calls to diabatic. 3. Added the new runtime parameter KAPPA_SHEAR_VERTEX_PSURF_BUG, which when set to False causes the surface pressures used in equation of state calculations in the kappa-shear code to avoid averaging any values from land points. 4. Stopped logging the debugging parameter DEBUG_KAPPA_SHEAR in a prelude to obsoleting it, as the debugging output this triggers is not so invasive as it once was (it is now a few checksums, and not extensive reporting on each column), and there is no reason why DEBUG should not trigger it, as is now the case. 4. Added chksum calls with appropriate halo sizes to check the MOM state before calls to set_diffusivity. 5. Added a haloshift=0 argument to a call to MOM_surface_chksum to avoid spuriously flagging halo regions that were not supposed to reproduce. The answers in most test cases in MOM6-examples are bitwise identical, and there are no changes to output files, but this does change answers in cases with VERTEX_SHEAR=True, including ice_ocean_SIS2/SIS2_bergs_cgrid, which was not previously reproducing across PE layouts. --- src/core/MOM.F90 | 41 ++++++++++++++----- .../vertical/MOM_diabatic_driver.F90 | 15 +++++-- .../vertical/MOM_kappa_shear.F90 | 35 ++++++++++++---- 3 files changed, 69 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a9b9c7fec4..3f60299b6b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -57,7 +57,7 @@ module MOM use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS use MOM_coord_initialization, only : MOM_initialize_coord -use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS +use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics @@ -595,8 +595,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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 (associated(forces%p_surf)) then !### This should be fluxes%p_surf! + if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -1137,6 +1138,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. type(group_pass_type) :: pass_T_S + integer :: halo_sz ! The size of a halo where data must be valid. logical :: showCallTree showCallTree = callTree_showQuery() @@ -1185,12 +1187,19 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) - if (CS%diabatic_first .and. associated(CS%tv%T)) then - ! Temperature and salinity need halo updates because they will be used - ! in the dynamics before they are changed again. - call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) - call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + if (associated(CS%tv%T)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + elseif (CS%diabatic_first) then + ! Temperature and salinity need halo updates because they will be used + ! in the dynamics before they are changed again. + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + endif endif CS%preadv_h_stored = .false. @@ -1225,7 +1234,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - integer :: i, j, k, is, ie, js, je, nz! , Isq, Ieq, Jsq, Jeq, n + integer :: halo_sz ! The size of a halo where data must be valid. + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke showCallTree = callTree_showQuery() @@ -1240,6 +1250,13 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) endif + if (associated(fluxes%p_surf)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass, halo=halo_sz) + endif + endif + if (update_BBL) then ! Calculate the BBL properties and store them inside visc (u,h). ! This is here so that CS%visc is updated before diabatic() when @@ -1278,12 +1295,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if ( CS%use_ALE_algorithm ) then call enable_averages(dtdia, Time_end_thermo, CS%diag) ! call pass_vector(u, v, G%Domain) + call cpu_clock_begin(id_clock_pass) if (associated(tv%T)) & call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) if (associated(tv%S)) & call create_group_pass(pass_T_S_h, tv%S, G%Domain, To_All+Omit_Corners, halo=1) call create_group_pass(pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) call do_group_pass(pass_T_S_h, G%Domain) + call cpu_clock_end(id_clock_pass) call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) @@ -3375,7 +3394,7 @@ subroutine extract_surface_state(CS, sfc_state_in) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US) + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7c24b774b3..de7d67b0ab 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -564,9 +564,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo h_orig(i,j,k) = h(i,j,k) ; eatr(i,j,k) = 0.0 ; ebtr(i,j,k) = 0.0 enddo ; enddo ; enddo - endif - if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) call geothermal(h, tv, dt, eatr, ebtr, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) @@ -602,6 +600,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -1386,6 +1386,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US,CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -2123,6 +2125,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) endif + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -2848,8 +2852,8 @@ end subroutine layered_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument -subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, & - minimum_forcing_depth, KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp) +subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, minimum_forcing_depth, & + KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp, diabatic_halo) type(diabatic_CS), intent(in ) :: CS !< module control structure ! All output arguments are optional type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure @@ -2862,6 +2866,8 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, !! and freshwater fluxes are applied [H ~> m or kg m-2]. type(diabatic_aux_CS), optional, pointer :: diabatic_aux_CSp !< A pointer to be set to the diabatic_aux !! control structure + integer, optional, intent( out) :: diabatic_halo !< The halo size where the diabatic algorithms + !! assume thermodynamics properties are valid. ! Pointers to control structures if (present(opacity_CSp)) opacity_CSp => CS%opacity_CSp @@ -2872,6 +2878,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth + if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff end subroutine extract_diabatic_member diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 04e67f0be5..343998a1af 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -80,6 +80,9 @@ module MOM_kappa_shear !! 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 :: psurf_bug !! If true, do a simple average of the cell surface pressures to get a + !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask + !! out any land points in the average. 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 @@ -534,9 +537,19 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo 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.0 + if (associated(p_surf)) then + if (CS%psurf_bug) then + ! This is wrong because it is averaging values from land in some places. + surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) + else + surface_pres = ((G%mask2dT(i,j) * p_surf(i,j) + G%mask2dT(i+1,j+1) * p_surf(i+1,j+1)) + & + (G%mask2dT(i+1,j) * p_surf(i+1,j) + G%mask2dT(i,j+1) * p_surf(i,j+1)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + endif + endif ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. @@ -1759,6 +1772,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables logical :: merge_mixedlayer + logical :: debug_shear logical :: just_read ! If true, this module is not used, so only read the parameters. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1879,11 +1893,18 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "could perhaps be made dynamic with an improved iterative solver.", & default=10.0, units="nondim", do_not_log=just_read) - call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & - "If true, write debugging data for the kappa-shear code. \n"//& - "Caution: this option is _very_ verbose and should only "//& - "be used in single-column mode!", & + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true., do_not_log=just_read) + call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", debug_shear, & + "If true, write debugging data for the kappa-shear code.", & + default=.false., debuggingParam=.true., do_not_log=.true.) + if (debug_shear) CS%debug = .true. + call get_param(param_file, mdl, "KAPPA_SHEAR_VERTEX_PSURF_BUG", CS%psurf_bug, & + "If true, do a simple average of the cell surface pressures to get a pressure "//& + "at the corner if VERTEX_SHEAR=True. Otherwise mask out any land points in "//& + "the average.", default=.true., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) + call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & "If true, use an older, dimensionally inconsistent estimate of the "//& "derivative of diffusivity with energy in the Newton's method iteration. "//& From 0eea62e22467fdbc3824c4cc5792709f1082d7aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Aug 2020 09:49:21 -0400 Subject: [PATCH 193/256] Fixed a dOxygen comment syntax error --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 343998a1af..3ba3d2b74c 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -80,7 +80,7 @@ module MOM_kappa_shear !! 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 :: psurf_bug !! If true, do a simple average of the cell surface pressures to get a + logical :: psurf_bug !< If true, do a simple average of the cell surface pressures to get a !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask !! out any land points in the average. logical :: all_layer_TKE_bug !< If true, report back the latest estimate of TKE instead of the From b204203ab68a3e9e1e1a7253969bd66ecda64e20 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 20 Aug 2020 17:36:50 -0400 Subject: [PATCH 194/256] catch missing files --- .../lateral/MOM_internal_tides.F90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index c327d1cece..2bb3c3b0f1 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2326,11 +2326,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "the coastline/ridge/shelf with respect to the equator.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & G%domain, timelevel=1) + else + if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & + "REFL_ANGLE_FILE: "//trim(filename)//" not found") endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -2343,10 +2346,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "The path to the file containing the reflection coefficients.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + else + if (trim(refl_pref_file) /= '' ) call MOM_error(FATAL, & + "REFL_PREF_FILE: "//trim(filename)//" not found") endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2368,10 +2374,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "The path to the file containing the double-reflective ridge tags.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + else + if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & + "REFL_DBL_FILE: "//trim(filename)//" not found") endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. From 4256a5c84cf9ae640e4d65defcd2e3fd10fbf2ed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Aug 2020 16:52:33 -0400 Subject: [PATCH 195/256] Fix epipycnal pairing array size declarations Corrected the size of 4 arrays used to describe layer pairings in tracer_epipycnal_ML_diff, to avoid the possibility of segmentation faults when there are very few interior layers compared with the number of mixed and buffer layers. Also corrected a number of spelling errors in comments. In runs that previously worked, all answers should be bitwise identical, and they are identical in all MOM6-examples test cases. --- src/tracer/MOM_tracer_hor_diff.F90 | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 02255d9424..53ed8881e3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -36,7 +36,7 @@ module MOM_tracer_hor_diff public tracer_hordiff, tracer_hor_diff_init, tracer_hor_diff_end -!> The ocntrol structure for along-layer and epineutral tracer diffusion +!> The control structure for along-layer and epineutral tracer diffusion type, public :: tracer_hor_diff_CS ; private real :: KhTr !< The along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula [nondim] @@ -122,7 +122,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online !! for epipycnal mixing between mixed layer and the interior. ! Optional inputs for offline tracer transport logical, optional, intent(in) :: do_online_flag !< If present and true, do online - !! tracer transport with stored velcities. + !! tracer transport with stored velocities. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: read_khdt_x !< If present, these are the zonal !! diffusivities from previous run. @@ -609,7 +609,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G), SZJ_(G), max(1,GV%nk_rho_varies)) :: & rho_coord ! The coordinate density that is used to mix along [R ~> kg m-3]. - ! The naming mnemnonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. + ! The naming mnemonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. ! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage. type(p2d), dimension(SZJ_(G)) :: & deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair [nondim]. @@ -644,10 +644,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_used_R, & ! have actually been used [H ~> m or kg m-2]. h_supply_frac_L, & ! The fraction of the demanded thickness that can h_supply_frac_R ! actually be supplied from a layer. - integer, dimension(SZK_(G)) :: & - kbs_Lp, & ! The sorted indicies of the Left and Right columns for - kbs_Rp ! each pairing. - integer, dimension(SZI_(G), SZJ_(G)) :: & num_srt, & ! The number of layers that are sorted in each column. k_end_srt, & ! The maximum index in each column that might need to be @@ -677,9 +673,16 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. real :: vol ! A cell volume or mass [H L2 ~> m3 or kg]. - logical, dimension(SZK_(G)) :: & + + ! The total number of pairings is usually much less than twice the number of layers, but + ! the memory in these 1-d columns of pairings can be allocated generously for safety. + integer, dimension(SZK_(G)*2) :: & + kbs_Lp, & ! The sorted indices of the Left and Right columns for + kbs_Rp ! each pairing. + logical, dimension(SZK_(G)*2) :: & 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)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] @@ -1186,8 +1189,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Ensure that the tracer flux does not drive the tracer values ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it - ! does that the concentration in both contributing peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer ! concentrations determining the valid range, the latter condition ! only enters for large values of the effective diffusive CFL number. if (Tr_flux > 0.0) then @@ -1221,8 +1224,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Ensure that the tracer flux does not drive the tracer values ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it - ! does that the concentration in both contributing peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer ! concentrations determining the valid range, the latter condition ! only enters for large values of the effective diffusive CFL number. if (Tr_flux < 0.0) then From c830ff5a4e2c09239c37569ef1d62235e5f2f02e Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Fri, 21 Aug 2020 18:42:21 -0400 Subject: [PATCH 196/256] In register_diag_field for some 2D diagnostics, changed to diag%axesCu1, diag%axesCv1 --- src/core/MOM_CoriolisAdv.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index cf274d32a9..c969a75313 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1193,7 +1193,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) !endif - CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCuL, Time, & + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEu_2d > 0) then @@ -1201,7 +1201,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif - CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCvL, Time, & + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEv_2d > 0) then @@ -1225,7 +1225,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !endif - CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCvL, Time, & + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxu_2d > 0) then @@ -1233,7 +1233,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) endif - CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCuL, Time, & + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxv_2d > 0) then From 8a8dad5d3af626adf1ae7e73e4225229a029df1f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Aug 2020 21:48:54 -0400 Subject: [PATCH 197/256] +Allow position=NORTH_FACE in pass_var calls Added code to handle the cases where the position argument to pass_var is set to NORTH_FACE or EAST_FACE. All answers are bitwise identical. --- src/framework/MOM_domains.F90 | 64 +++++++++++++++++++++++------------ 1 file changed, 42 insertions(+), 22 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 7cf9df39f1..f578df61c9 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -26,11 +26,12 @@ module MOM_domains use mpp_domains_mod, only : mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent -use mpp_parameter_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER -use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE -use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER -use fms_io_mod, only : file_exist, parse_mask_table -use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get implicit none ; private @@ -40,7 +41,8 @@ module MOM_domains public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass @@ -153,8 +155,8 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER by - !! default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -198,8 +200,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo !! by default. integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, @@ -267,6 +269,24 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner elseif (size(array,2) == jed+1) then jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif else call MOM_error(FATAL, "pass_var_2d: Unrecognized position") endif @@ -297,8 +317,8 @@ function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -342,8 +362,8 @@ function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -390,8 +410,8 @@ subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -433,8 +453,8 @@ subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -901,8 +921,8 @@ subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -946,8 +966,8 @@ subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be From a05eeeee790bd5ae00175d562440c3b5c5f55bcb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Aug 2020 15:39:03 -0400 Subject: [PATCH 198/256] +Revised interface to write_cputime Revised the interface to write_cputime, adding one optional argument and making another intent inout argument optional when it was not going to be reset, and also adding a flush of an I/O channel, and added a new subroutine, MOM_write_cputime_end, to be called during cleanup, potentially via write_cputime. The write_cputime calls from the solo driver routines have been modified in accord with these changes, and a final write_cputime call has been added so that the time used by the whole run is reported. These changes should address the problems in MOM6 issue #853, which should be closed once this PR is merged into dev/gfdl. All answers are bitwise identical, but there are minor interface changes and a new publicly visible subroutine. --- .../ice_solo_driver/ice_shelf_driver.F90 | 5 +- config_src/solo_driver/MOM_driver.F90 | 5 +- src/framework/MOM_write_cputime.F90 | 51 ++++++++++++++----- 3 files changed, 44 insertions(+), 17 deletions(-) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 9113b60c64..b1323a5485 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -353,7 +353,7 @@ program Shelf_main call close_file(unit) endif - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -403,7 +403,7 @@ program Shelf_main Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns, nmax, write_CPU_CSp) + call write_cputime(Time, ns, write_CPU_CSp, nmax) endif ; endif ! See if it is time to write out a restart file - timestamped or not. @@ -459,6 +459,7 @@ program Shelf_main call callTree_waypoint("End Shelf_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index f180cd9717..ba52d9c02a 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -447,7 +447,7 @@ program MOM_main call close_file(unit) endif - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -564,7 +564,7 @@ program MOM_main Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) + call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) @@ -652,6 +652,7 @@ program MOM_main call callTree_waypoint("End MOM_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 1f0e001073..2c1cb3378a 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -3,15 +3,15 @@ module MOM_write_cputime ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs, pe_here, num_pes +use MOM_coms, only : sum_across_PEs, num_pes use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe -use MOM_io, only : open_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE +use MOM_io, only : open_file, close_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_time_manager, only : time_type, get_time, operator(>) implicit none ; private -public write_cputime, MOM_write_cputime_init, write_cputime_start_clock +public write_cputime, MOM_write_cputime_init, MOM_write_cputime_end, write_cputime_start_clock !----------------------------------------------------------------------- @@ -33,7 +33,7 @@ module MOM_write_cputime real :: cputime2 = 0.0 !< The accumulated cpu time. integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. integer :: prev_n = 0 !< The value of n from the last call. - integer :: fileCPU_ascii !< The unit number of the CPU time file. + integer :: fileCPU_ascii= -1 !< The unit number of the CPU time file. character(len=200) :: CPUfile !< The name of the CPU time file. end type write_cputime_CS @@ -101,16 +101,35 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init -!> This subroutine assesses how much CPU time the model has taken and determines how long the model -!! should be run before it saves a restart file and stops itself. -subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day !< The current model time. - integer, intent(in) :: n !< The time step number of the current execution. - integer, intent(inout) :: nmax !< The number of iterations after which to stop so - !! that the simulation will not run out of CPU time. - type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous +!> Close the MOM_write_cputime module. +subroutine MOM_write_cputime_end(CS) + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous !! call to MOM_write_cputime_init. + if (.not.associated(CS)) return + + ! Flush and close the output files. + if (is_root_pe() .and. CS%fileCPU_ascii > 0) then + call flush(CS%fileCPU_ascii) + call close_file(CS%fileCPU_ascii) + endif + + deallocate(CS) + +end subroutine MOM_write_cputime_end + +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. Optionally this may also be used +!! to trigger this module's end routine. +subroutine write_cputime(day, n, CS, nmax, call_end) + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + integer, optional, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + logical, optional, intent(in) :: call_end !< If true, also call MOM_write_cputime_end. + ! Local variables real :: d_cputime ! The change in CPU time since the last call ! this subroutine. @@ -145,7 +164,7 @@ subroutine write_cputime(day, n, nmax, CS) ((CS%dn_dcpu_min*d_cputime < (n - CS%prev_n)) .or. & (CS%dn_dcpu_min < 0.0))) & CS%dn_dcpu_min = (n - CS%prev_n) / d_cputime - if (CS%dn_dcpu_min >= 0.0) then + if (present(nmax) .and. (CS%dn_dcpu_min >= 0.0)) then ! Have the model stop itself after 95% of the CPU time has been used. nmax = n + INT( CS%dn_dcpu_min * & (0.95*CS%maxcpu * REAL(num_pes())*CLOCKS_PER_SEC - & @@ -180,9 +199,15 @@ subroutine write_cputime(day, n, nmax, CS) write(CS%fileCPU_ascii,'(F12.3,", "I11,", ", F12.3,", ", F12.3)') & reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & d_cputime / real(CLOCKS_PER_SEC) + + call flush(CS%fileCPU_ascii) endif CS%previous_calls = CS%previous_calls + 1 + if (present(call_end)) then + if (call_end) call MOM_write_cputime_end(CS) + endif + end subroutine write_cputime !> \namespace mom_write_cputime From b2010ddb8652b4b169efb1663b3cfb6cd52754e1 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 17:27:13 -0400 Subject: [PATCH 199/256] Updating the default setting for BBL_USE_EOS to match USE_REGRIDDING --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index d4d3251885..12c3aa4486 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1846,6 +1846,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, MLE_use_PBL_MLD logical :: use_CVMix_ddiff, differential_diffusion, use_KPP + logical :: use_regridding 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". @@ -1991,10 +1992,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "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, "USE_REGRIDDING", use_regridding, & + do_not_log = .true.) 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 "//& - "the layer target potential densities.", default=.false.) + "the layer target potential densities. The default of "//& + "this is determined by USE_REGRIDDING.", default=use_regridding) endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& From 329b9006490c90c8616b8ea2af5441e8a848e2f0 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 17:34:08 -0400 Subject: [PATCH 200/256] Adding FATAL error if trying to use BBL_USE_EOS = False in ALE mode --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 12c3aa4486..29098082e3 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1999,6 +1999,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "properties of the bottom boundary layer. Otherwise use "//& "the layer target potential densities. The default of "//& "this is determined by USE_REGRIDDING.", default=use_regridding) + if (use_regridding .and. (.not. CS%BBL_use_EOS)) & + call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to "//& + "set BBL_USE_EOS to True") endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& From ca10be7c1b58563470fc4f5f783e9a80e6aff40f Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 18:12:11 -0400 Subject: [PATCH 201/256] Registering default for USE_REGRIDDING to MOM_set_viscosity --- 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 29098082e3..02fa647e7e 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1993,7 +1993,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "USE_REGRIDDING", use_regridding, & - do_not_log = .true.) + do_not_log = .true., default = .false. ) 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 "//& From c8a1f077225fe7f7d1af2bf523f2265e7d95a90a Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Fri, 28 Aug 2020 22:58:24 -0400 Subject: [PATCH 202/256] Set variable_buoyforce = True (even if False is chosen in MOM_input) for buoyancy surface restoration = True. --- config_src/solo_driver/MOM_surface_forcing.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 0a56abb681..8db310893b 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -302,6 +302,12 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif ! calls to various buoyancy forcing options + if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then + call MOM_error(WARNING, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Changed to VARIABLE_BUOYFORCE = True") + CS%variable_buoyforce = .true. + endif + if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then if (trim(CS%buoy_config) == "file") then From 995e422322657eb5972b5db5187e5ea7a233293f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 31 Aug 2020 18:07:24 -0400 Subject: [PATCH 203/256] Fix spelling in comments and line length - One line was too long - Noticed several spelling and grammar problems in comments --- src/core/MOM_PressureForce_FV.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index fc2d40eaf3..0165a44642 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -480,9 +480,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 :: dTdi2, dTdj2 ! Differences in T variance [degC2] - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stenil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencial of H [H ~> m] + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -506,9 +505,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%Stanley_T2_det_coeff>=0.) then if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! Strictly speaking we should be estimate the horizontal grid-scale variance + ! Strictly speaking we should estimate the *horizontal* grid-scale variance ! but neither of the following blocks make a rotation to the horizontal - ! but work along coordinate + ! and instead work along coordinate. ! This block calculates a simple |delta T| along coordinates and does ! not allow vanishing layer thicknesses or layers tracking topography @@ -529,7 +528,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil ! Mean of T - Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) ; Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) + Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) + Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. From 4668673cf4ec410bd2f2c56fd006be65af2679bb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 1 Sep 2020 12:41:24 -0400 Subject: [PATCH 204/256] .testing Makefile typo fix The restart tests were incorrectly reported as restart.diag tests in the output log. This patch fixes these typos. Restart test diagnostics are currently not checked, and this patch is a good reminder that we need to get these in ASAP. --- .testing/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index ab978fdadc..32a5db06ab 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -293,9 +293,9 @@ $(eval $(call CMP_RULE,regression,symmetric target)) || !( \ mkdir -p results/$*; \ (diff $$^ | tee results/$*/chksum_diag.restart.diff | head) ; \ - echo -e "${FAIL}: Diagnostics $*.restart.diag have changed." \ + echo -e "${FAIL}: Solutions $*.restart have changed." \ ) - @echo -e "${PASS}: Diagnostics $*.restart.diag agree." + @echo -e "${PASS}: Solutions $*.restart agree." # TODO: chksum_diag parsing of restart files From bbc0f0dc30a11e0c855e0e895e937751ad3d7637 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 15:36:10 -0400 Subject: [PATCH 205/256] Adds some targets to run groups of TCs - New targets run.symmetric, run.asymmetric, run.nans, run.openmp added for convenience and in anticipation of want to run the model just once for coverage upload. --- .testing/Makefile | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.testing/Makefile b/.testing/Makefile index 32a5db06ab..6f3553a694 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -243,6 +243,12 @@ 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) +.PHONY: run.symmetric run.asymmetric run.nans run.openmp +run.symmetric: $(foreach c,$(CONFIGS),work/$(c)/symmetric/ocean.stats) +run.asymmetric: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(CONFIGS),work/$(c)/asymmetric/ocean.stats) +run.nans: $(foreach c,$(CONFIGS),work/$(c)/nan/ocean.stats) +run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) + # Color highlights for test results RED=\033[0;31m GREEN=\033[0;32m From 53b21b6636ba649f5245ec3e61a641601d683dab Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 15:38:34 -0400 Subject: [PATCH 206/256] Adds a coverage job to Travis-CI sequence - Keeping the coverage within the regression job, this adds a conditional job for all other that uploads coverage. --- .travis.yml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/.travis.yml b/.travis.yml index 10816b7122..03bdff31dc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -41,6 +41,8 @@ jobs: - make test.summary # NOTE: Code coverage upload is here to reduce load imbalance + # We do coverage with the regressions if part of a pull request + # otherwise as a separate job. - if: type = pull_request env: - JOB="x86 Regression testing" @@ -57,6 +59,19 @@ jobs: - make -k -s test.regressions - make test.summary + - if: NOT type = pull_request + env: + - JOB="Coverage upload" + - REPORT_COVERAGE=true + - DO_REGRESSION_TESTS=false + - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + script: + - cd .testing + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - make build/symmetric/MOM6 + - echo -en 'travis_fold:end:script.1\\r' + - make -k -s run.symmetric + - arch: arm64 env: - JOB="ARM64 Configuration testing" From 4dbc12697dd536f019c3282caf56b1975c064112 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 17:50:58 -0400 Subject: [PATCH 207/256] Adds land masking of thicknesses in SGS estimate - The restart tests were failing because land values differ before/after a restart. Adding 2d land masking of h value in the stencil removes the sensitivity. --- src/core/MOM_PressureForce_FV.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0165a44642..942c29854e 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -524,7 +524,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! This block does a thickness weighted variance calculation and helps control for ! extreme gradients along layers which are vanished against topography. It is ! still a poor approximation in the interior when coordinates are strongly tilted. - hl(1) = h(i,j,k) ; hl(2) = h(i-1,j,k) ; hl(3) = h(i+1,j,k) ; hl(4) = h(i,j-1,k) ; hl(5) = h(i,j+1,k) + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil ! Mean of T From f841d28a800fa396016967243c5bb11923301fea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Sep 2020 20:30:32 -0400 Subject: [PATCH 208/256] *Corrected the test whether to use fluxes%psurf Changed the test to detect whether the surface pressure has been set for use in the equation of state calculations in the thermodynamic step from evaluating whether forces%p_surf is associated to whether fluxes%p_surf is associated. Because these two pointers often point to the same array, this only changes answers in the coupled_AM2_LM3_SIS2/Intersperse_ice_1deg test case, but it could change answer in other cases, depending on how MOM6 is called. Because this only appears to change answers for one test case that is not widely used yet, and does not impact configurations that are used outside of GFDL, the decision was taken not to introduce a bug flag to preserve the old incorrect answers. --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3f60299b6b..3398c14d50 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -595,7 +595,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() - if (associated(forces%p_surf)) then !### This should be fluxes%p_surf! + if (associated(fluxes%p_surf)) then if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) From e69287ab4ff1c738109f738ab3cea0084b1e2fd7 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 09:05:44 -0400 Subject: [PATCH 209/256] Autoconf-based build framework This patch is a first draft of an autoconf-based build for MOM6. This is a hybrid solution which relies on mkmf and list_paths to automatically generate the model dependencies, but uses autoconf to determine the necessary compiler flags for building the model. Recommended instructions for testing the build system, as well as instructions for new users, are shown below. ``` # (Optional) Fetch mkmf and build FMS cd deps make -j cd .. # Set up the autoconf build files autoreconf # Configure and build the model in /build mkdir -p build cd build ../configure make -j ``` As with standard autoconf builds, compilers and flags can be configured with prepended arguments, e.g. ``` FC=mpifort FCFLAGS="-g -O0 -Wall -Wextra" ./configure make ``` Introduction of autoconf configuration should not interfere with any existing mkmf-based build procedures. A more detailed discussion is provided below. ---- At minimum, only the following instructions would be required: ``` autoreconf ./configure make ``` but this requires that both mkmf and FMS be accessible in standard searchable directories. A more realistic MOM6-only build would be as shown below ``` autoreconf PATH="path/to/mkmf/bin:${PATH}" \ FCFLAGS="-Ipath/to/fms_mods" \ LDFLAGS="-Lpath/to/fms_lib" \ ./configure make ``` where `path/to/xxx` points to the location of the pre-installed content. To alleviate this issue, a Makefile in the `deps` directory has been provided, which checks out copies of mkmf and FMS and places them in the `deps` directory. If the MOM6 `./configure` script is unable to find mkmf or FMS, then it will automatically continue to search inside of the `deps` directory. ---- The `deps` directory provides templates for an autoconf build of FMS resembling our MOM6 build. The Makefile provides the following rules: `make` or `make all`: Fetch mkmf and FMS, build FMS, install module files to `deps/include` and `libFMS.a` to `deps/lib`. `make clean` Delete the compiled FMS files in `deps/fms/build` but not the installed libraries or module files. `make distclean` Delete all files produced by the Makefile. Much of the FMS source configuration has been moved to the `deps` Makefile. The available hooks and default values are shown below. ``` MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git MKMF_COMMIT ?= master FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git FMS_COMMIT ?= 2019.01.03 FCFLAGS_FMS ?= ``` The FCFLAGS_FMS hook is provided to override the default autoconf value, `-g -O2`. Although FMS provides its own automake build framework, the 2019.01.03 release cannot be used with MOM6 due to missing components in its libtool configuration (`random_number`). The build time is also significantly longer due to incorrect dependencies in the automake configuration. Most of the issues describe above have either been or will soon be resolved in newer FMS releases, and we may be able to transition to the FMS automake in a future release. ---- The `.testing` directory has been reworked to use the autoconf builds of MOM6 and FMS, but should otherwise work the same as before. ``` cd .testing make -j make -j test ``` The changes required to use autoconf have been incorporated into the `.testing` Makefile. This can create issues with the management of FMS, which is now configured inside of `deps/Makefile` rather than in `.testing`. Also, a rebuild of FMS will require an explicit wipe of FMS in `deps`, which can be done with the following command. ``` make -C ../deps distclean ``` Platform-specific flags are now managed in the `config.mk` file rather than in a mkmf template. The following hooks are provided, with default values shown. ``` FCFLAGS_DEBUG ?= -g -O0 FCFLAGS_REPRO ?= -g -O2 FCFLAGS_INIT ?= FCFLAGS_COVERAGE ?= ``` The intention is to provide some correspondence to the GFDL DEBUG and REPRO production builds. Any FMS build produced by `make` in `.testing` will use the `FCFLAGS_DEBUG` variable. Although `FCFLAGS_INIT` is intended for intialization, it acts as more of a general-purpose flag which is applied to MOM6 but not FMS. ---- Other points of interest - This build system only uses autoconf. It does not use automake or libtools. - autoconf will determine any necessary flags required for building MOM6, but does not attempt to use optional flags for debugging or performance. Flags required for testing or production builds must still track or otherwise manage their own compiler flags (FCFLAGS, etc). - The MOM6 `./configure` script requires a FMS library and module files as part of its build validation. This is why we must pre-build FMS before calling `./configure`. - FCFLAGS defaults to `-g -O2`. Any explicit setting of FCFLAGS will remove and replace these flags. Other flags, such as `-fdefault-real-8` will be appended as needed and do not need to be managed. - Support M4 macros have been tested on GCC, Intel, PGI, and Cray compilers. The macros can be extended to other compilers and older versions of these compilers if necessary. ---- Known issues - The macro used for the MPI launcher (AX_MPI) can potentially locate a MPIFC (e.g. mpif90) which does not match FC. For example, FC will tend to default to GFortran, but mpif90 may use Intel Fortran. While FC is quickly replaced with MPIFC, there are some initial tests which may fail if FCFLAGS was defined for the non-GFortran compiler. This can be resolved by explicitly setting both FC and FCFLAGS for the same compiler. - Since we use git for both development and distribution, we may want to pre-build the configure script and support files, eliminating the `autoreconf` step. --- .gitignore | 11 +- .testing/.gitignore | 8 +- .testing/Makefile | 211 ++++++++++++--------- .testing/linux-ubuntu-xenial-gnu.mk | 279 ---------------------------- .travis.yml | 27 ++- Makefile.in | 82 ++++++++ configure.ac | 156 ++++++++++++++++ deps/.gitignore | 5 + deps/Makefile | 94 ++++++++++ deps/Makefile.fms.in | 45 +++++ deps/configure.fms.ac | 123 ++++++++++++ m4/ax_fc_allow_arg_mismatch.m4 | 58 ++++++ m4/ax_fc_allow_invalid_boz.m4 | 54 ++++++ m4/ax_fc_check_lib.m4 | 52 ++++++ m4/ax_fc_check_module.m4 | 28 +++ m4/ax_fc_cray_pointer.m4 | 53 ++++++ m4/ax_fc_real8.m4 | 86 +++++++++ m4/ax_mpi.m4 | 176 ++++++++++++++++++ 18 files changed, 1168 insertions(+), 380 deletions(-) delete mode 100644 .testing/linux-ubuntu-xenial-gnu.mk create mode 100644 Makefile.in create mode 100644 configure.ac create mode 100644 deps/.gitignore create mode 100644 deps/Makefile create mode 100644 deps/Makefile.fms.in create mode 100644 deps/configure.fms.ac create mode 100644 m4/ax_fc_allow_arg_mismatch.m4 create mode 100644 m4/ax_fc_allow_invalid_boz.m4 create mode 100644 m4/ax_fc_check_lib.m4 create mode 100644 m4/ax_fc_check_module.m4 create mode 100644 m4/ax_fc_cray_pointer.m4 create mode 100644 m4/ax_fc_real8.m4 create mode 100644 m4/ax_mpi.m4 diff --git a/.gitignore b/.gitignore index e534738ed7..8a79222df4 100644 --- a/.gitignore +++ b/.gitignore @@ -4,5 +4,12 @@ html *.log MOM6 -build/ -deps/ + +# Autoconf +/aclocal.m4 +/autom4te.cache/ +/config.log +/config.status +/configure +/Makefile +/Makefile.mkmf diff --git a/.testing/.gitignore b/.testing/.gitignore index 441e73b8e8..ec8eae6348 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -1,3 +1,5 @@ -config.mk -work/ -results/ +# Test output +/config.mk +/build/ +/work/ +/results/ diff --git a/.testing/Makefile b/.testing/Makefile index 6f3553a694..dd0db892ac 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -4,36 +4,39 @@ SHELL = bash # User-defined configuration -include config.mk -# Default configurations +# Set the MPI launcher here MPIRUN ?= mpirun -DO_REPRO_TESTS ?= true -#--- -# Dependencies -DEPS = deps +# Many compilers (Intel, GCC on ARM64) do not yet produce identical results +# across DEBUG and REPRO builds. For these platforms, set to false +DO_REPRO_TESTS ?= true -# 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) +# Default target compiler flags +# NOTE: FMS will be built using FCFLAGS_DEBUG +FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS_REPRO ?= -g -O2 +FCFLAGS_INIT ?= +FCFLAGS_COVERAGE ?= +# Addtional notes: +# +# - The default values are simple, minimalist flags, supported by nearly all +# compilers and meant to represent GFDL's canonical DEBUG and REPRO builds. +# +# - These flags should be configured outside of the Makefile, either with +# config.mk or as environment variables. +# +# - FMS cannot be build with the same aggressive initialization flags as MOM6, +# so FCFLAGS_INIT is used to provide additional MOM6 configuration. -# FMS framework -FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.03 -FMS := $(DEPS)/fms #--- -# Build configuration +# Dependencies +DEPS = ../deps -# Build settings -MKMF_CPP = "-Duse_libMPI -Duse_netCDF -DSPMD" +# mkmf, list_paths (GFDL build toolchain) +LIST_PATHS := $(DEPS)/bin/list_paths +MKMF := $(DEPS)/bin/mkmf -# Environment -# TODO: This info ought to be determined by CMake, automake, etc. -#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 @@ -78,6 +81,7 @@ else TARGET_CODEBASE = endif + # 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 @@ -85,13 +89,15 @@ endif SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) -MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) \ - $(wildcard ../config_src/ext*/*/*.F90) +MOM_SOURCE = $(call SOURCE,../src) \ + $(wildcard ../config_src/solo_driver/*.F90) \ + $(wildcard ../config_src/ext*/*/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/solo_driver/*.F90) \ $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) + #--- # Python preprocessing environment configuration @@ -126,85 +132,114 @@ build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) BUILD_TARGETS = MOM6 Makefile path_names .PRECIOUS: $(foreach b,$(BUILDS),$(foreach f,$(BUILD_TARGETS),build/$(b)/$(f))) +# Compiler flags + # Conditionally build symmetric with coverage support -COVFLAG=$(if $(REPORT_COVERAGE),COVERAGE=1,) +COVERAGE=$(if $(REPORT_COVERAGE),"$(FCFLAGS_COVERAGE)",) -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 INIT=1 +# TODO: We should probably build TARGET with the FMS that it was configured +# to use. But for now we use the same FMS over all builds. +FCFLAGS_TARGET_FMS = -I../../../deps/include -L../../../deps/lib +PATH_TARGET = PATH="${PATH}:../../../deps/bin" -build/asymmetric/path_names: GRID_SRC=config_src/dynamic -build/%/path_names: GRID_SRC=config_src/dynamic_symmetric +# Define the build targets in terms of the traditional DEBUG/REPRO/etc labels +FCFLAGS_SYMMETRIC = +ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT)$(COVERAGE),) + FCFLAGS_SYMMETRIC := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(COVERAGE)" +endif -build/%/MOM6: build/%/Makefile $(FMS)/lib/libfms.a - $(MAKE) -C $(@D) $(MOMFLAGS) $(@F) +FCFLAGS_TARGET = +FCFLAGS_ASYMMETRIC = +FCFLAGS_OPENMP = +ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT),) + FCFLAGS_TARGET := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_TARGET_FMS)" + FCFLAGS_ASYMMETRIC := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" + FCFLAGS_OPENMP := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" +endif -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 +FCFLAGS_REPRO_RUN = +ifneq ($(FCFLAGS_REPRO),) + FCFLAGS_REPRO_RUN := FCFLAGS="$(FCFLAGS_REPRO)" +endif -# 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)/config_src/ext* \ - ../../$(TARGET_CODEBASE)/$(GRID_SRC) +# Environment variable configuration +build/symmetric/Makefile: FC_ENV=$(FCFLAGS_SYMMETRIC) +build/asymmetric/Makefile: FC_ENV=$(FCFLAGS_ASYMMETRIC) +build/repro/Makefile: FC_ENV=$(FCFLAGS_REPRO_RUN) +build/openmp/Makefile: FC_ENV=$(FCFLAGS_OPENMP) +build/target/Makefile: FC_ENV=$(FCFLAGS_TARGET) $(PATH_TARGET) -build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) - mkdir -p $(@D) - cd $(@D) && $(LIST_PATHS) -l \ - ../../../src \ - ../../../config_src/solo_driver \ - ../../../config_src/ext* \ - ../../../$(GRID_SRC) -# Target repository for regression tests -$(TARGET_CODEBASE): - git clone --recursive $(MOM_TARGET_URL) $@ - cd $@ && git checkout $(MOM_TARGET_BRANCH) +# Configure script flags +build/asymmetric/Makefile: AC_FLAGS= +build/openmp/Makefile: AC_FLAGS=--enable-symmetric --enable-openmp +build/target/Makefile: AC_FLAGS=--srcdir=../../$(TARGET_CODEBASE) --enable-symmetric +build/%/Makefile: AC_FLAGS=--enable-symmetric -#---- -# FMS build +# Fetch regression target source code +build/target/Makefile: $(TARGET_CODEBASE) + -$(FMS)/lib/libfms.a: $(FMS)/build/Makefile - mkdir -p $(FMS)/lib - cd $(FMS)/build && $(MAKE) NETCDF=3 DEBUG=1 ../lib/libfms.a +# Define source code dependencies +# NOTE: ./configure is too much, but Makefile is not enough! +# Ideally we would want to re-run both Makefile and mkmf, but our mkmf call +# is inside ./configure, so we must re-run ./configure as well. +$(foreach b,$(filter-out target,$(BUILDS)),build/$(b)/Makefile): $(MOM_SOURCE) +build/target/configure: $(TARGET_SOURCE) -$(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 -$(FMS)/build/path_names: $(LIST_PATHS) $(FMS)/src $(FMS_SOURCE) +# Build MOM6 +.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/MOM6) +build/%/MOM6: build/%/Makefile + cd $(@D) && time $(MAKE) -j + + +# Use autoconf to construct the Makefile for each target +.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/Makefile) +build/%/Makefile: ../configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) - cd $(@D) && $(LIST_PATHS) -l ../src + cd $(@D) \ + && $(FC_ENV) ../../../configure $(AC_FLAGS) \ + || (cat config.log && false) -$(FMS)/src: - git clone $(FMS_URL) $@ - cd $@; git checkout $(FMS_COMMIT) +../configure: ../configure.ac ../Makefile.in ../m4 + autoreconf -i $< + + +# Fetch the regression target codebase +build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) + mkdir -p $(@D) + cd $(@D) \ + && $(FC_ENV) ../../$(TARGET_CODEBASE)/configure $(AC_FLAGS) \ + || (cat config.log && false) + + +$(TARGET_CODEBASE)/configure: $(TARGET_CODEBASE) + autoreconf -i $< -#--- -# Build Toolchain -$(LIST_PATHS) $(MKMF): - git clone $(MKMF_URL) $(DEPS)/mkmf - cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) +$(TARGET_CODEBASE): + git clone --recursive $(MOM_TARGET_URL) $@ + cd $@ && git checkout $(MOM_TARGET_BRANCH) + # Copy modern autoconf files to target? + cp ../configure.ac $(TARGET_CODEBASE)/ + cp ../Makefile.in $(TARGET_CODEBASE)/ + cp -r ../m4 $(TARGET_CODEBASE)/ + + +# FMS +$(DEPS)/lib/libFMS.a: $(DEPS)/Makefile $(FMS_SOURCE) $(MKMF) $(LIST_PATHS) + FCFLAGS_FMS="$(FCFLAGS_DEBUG)" $(MAKE) -C $(DEPS) lib/libFMS.a + + +# mkmf +$(MKMF) $(LIST_PATHS): $(DEPS)/mkmf + +$(DEPS)/mkmf: $(DEPS)/Makefile + $(MAKE) -C $(DEPS) bin/$(@F) #--- @@ -305,6 +340,7 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # TODO: chksum_diag parsing of restart files + #--- # Test run output files @@ -331,7 +367,7 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ - && $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ + && time $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ @@ -391,7 +427,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 && 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 $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ + cd $(@D) && time $(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 ; \ @@ -402,7 +438,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 mkdir $(@D)/RESTART cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ + cd $(@D) && time $(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 ; \ @@ -446,6 +482,7 @@ clean: clean.stats @[ $$(basename $$(pwd)) = .testing ] rm -rf build + .PHONY: clean.stats clean.stats: @[ $$(basename $$(pwd)) = .testing ] diff --git a/.testing/linux-ubuntu-xenial-gnu.mk b/.testing/linux-ubuntu-xenial-gnu.mk deleted file mode 100644 index 04ba952408..0000000000 --- a/.testing/linux-ubuntu-xenial-gnu.mk +++ /dev/null @@ -1,279 +0,0 @@ -# Template for the GNU Compiler Collection on Xenial version of Ubuntu Linux systems (used by Travis-CI) -# -# Typical use with mkmf -# mkmf -t linux-ubuntu-xenial-gnu.mk -c"-Duse_libMPI -Duse_netCDF" path_names /usr/local/include - -############ -# Commands Macors -FC = mpif90 -CC = mpicc -LD = mpif90 $(MAIN_PROGRAM) - -####################### -# Build target macros -# -# Macros that modify compiler flags used in the build. Target -# macrose are usually set on the call to make: -# -# make REPRO=on NETCDF=3 -# -# Most target macros are activated when their value is non-blank. -# Some have a single value that is checked. Others will use the -# value of the macro in the compile command. - -DEBUG = # If non-blank, perform a debug build (Cannot be - # mixed with REPRO or TEST) - -REPRO = # If non-blank, perform a build that guarentees - # reprodicuibilty from run to run. Cannot be used - # with DEBUG or TEST - -TEST = # If non-blank, use the compiler options defined in - # the FFLAGS_TEST and CFLAGS_TEST macros. Cannot be - # use with REPRO or DEBUG - -VERBOSE = # If non-blank, add additional verbosity compiler - # options - -OPENMP = # If non-blank, compile with openmp enabled - -NO_OVERRIDE_LIMITS = # If non-blank, do not use the -qoverride-limits - # compiler option. Default behavior is to compile - # with -qoverride-limits. - -NETCDF = # If value is '3' and CPPDEFS contains - # '-Duse_netCDF', then the additional cpp macro - # '-Duse_LARGEFILE' is added to the CPPDEFS macro. - -INCLUDES = # A list of -I Include directories to be added to the - # the compile command. - -SSE = # The SSE options to be used to compile. If blank, - # than use the default SSE settings for the host. - # Current default is to use SSE2. - -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)))) -ifneq ($(need),$(ok)) -$(error Need at least make version $(need). Load module gmake/3.81) -endif - -# REPRO, DEBUG and TEST need to be mutually exclusive of each other. -# Make sure the user hasn't supplied two at the same time -ifdef REPRO -ifneq ($(DEBUG),) -$(error Options REPRO and DEBUG cannot be used together) -else ifneq ($(TEST),) -$(error Options REPRO and TEST cannot be used together) -endif -else ifdef DEBUG -ifneq ($(TEST),) -$(error Options DEBUG and TEST cannot be used together) -endif -endif - -MAKEFLAGS += --jobs=$(shell grep '^processor' /proc/cpuinfo | wc -l) - -# Macro for Fortran preprocessor -FPPFLAGS := $(INCLUDES) -# Fortran Compiler flags for the NetCDF library -FPPFLAGS += $(shell nf-config --fflags) - -# Base set of Fortran compiler flags -FFLAGS := -fcray-pointer -fdefault-double-8 -fdefault-real-8 -Waliasing -ffree-line-length-none -fno-range-check - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -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 -FFLAGS_VERBOSE = -FFLAGS_COVERAGE = --coverage - -# Macro for C preprocessor -CPPFLAGS = $(INCLUDES) -# C Compiler flags for the NetCDF library -CPPFLAGS += $(shell nf-config --cflags) - -# Base set of C compiler flags -CFLAGS := -D__IFC - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -CFLAGS_OPT = -O2 -CFLAGS_REPRO = -O2 -CFLAGS_DEBUG = -O0 -g - -# Flags to add additional build options -CFLAGS_OPENMP = -fopenmp -CFLAGS_VERBOSE = -CFLAGS_COVERAGE = --coverage - -# Optional Testing compile flags. Mutually exclusive from DEBUG, REPRO, and OPT -# *_TEST will match the production if no new option(s) is(are) to be tested. -FFLAGS_TEST = $(FFLAGS_OPT) -CFLAGS_TEST = $(CFLAGS_OPT) - -# Linking flags -LDFLAGS := -LDFLAGS_OPENMP := -fopenmp -LDFLAGS_VERBOSE := -LDFLAGS_COVERAGE := --coverage - -# Start with a blank LIBS -LIBS = -# NetCDF library flags -LIBS += $(shell nf-config --flibs) - -# Get compile flags based on target macros. -ifdef REPRO -CFLAGS += $(CFLAGS_REPRO) -FFLAGS += $(FFLAGS_REPRO) -else ifdef DEBUG -CFLAGS += $(CFLAGS_DEBUG) -FFLAGS += $(FFLAGS_DEBUG) -else ifdef TEST -CFLAGS += $(CFLAGS_TEST) -FFLAGS += $(FFLAGS_TEST) -else -CFLAGS += $(CFLAGS_OPT) -FFLAGS += $(FFLAGS_OPT) -endif - -ifdef OPENMP -CFLAGS += $(CFLAGS_OPENMP) -FFLAGS += $(FFLAGS_OPENMP) -LDFLAGS += $(LDFLAGS_OPENMP) -endif - -ifdef SSE -CFLAGS += $(SSE) -FFLAGS += $(SSE) -endif - -ifdef NO_OVERRIDE_LIMITS -FFLAGS += $(FFLAGS_OVERRIDE_LIMITS) -endif - -ifdef VERBOSE -CFLAGS += $(CFLAGS_VERBOSE) -FFLAGS += $(FFLAGS_VERBOSE) -LDFLAGS += $(LDFLAGS_VERBOSE) -endif - -ifeq ($(NETCDF),3) - # add the use_LARGEFILE cppdef - ifneq ($(findstring -Duse_netCDF,$(CPPDEFS)),) - CPPDEFS += -Duse_LARGEFILE - endif -endif - -ifdef COVERAGE -ifdef BUILDROOT -PROF_DIR=-prof-dir=$(BUILDROOT) -endif -CFLAGS += $(CFLAGS_COVERAGE) $(PROF_DIR) -FFLAGS += $(FFLAGS_COVERAGE) $(PROF_DIR) -LDFLAGS += $(LDFLAGS_COVERAGE) $(PROF_DIR) -endif - -LDFLAGS += $(LIBS) - -#--------------------------------------------------------------------------- -# you should never need to change any lines below. - -# see the MIPSPro F90 manual for more details on some of the file extensions -# discussed here. -# this makefile template recognizes fortran sourcefiles with extensions -# .f, .f90, .F, .F90. Given a sourcefile ., where is one of -# the above, this provides a number of default actions: - -# make .opt create an optimization report -# make .o create an object file -# make .s create an assembly listing -# make .x create an executable file, assuming standalone -# source -# make .i create a preprocessed file (for .F) -# make .i90 create a preprocessed file (for .F90) - -# The macro TMPFILES is provided to slate files like the above for removal. - -RM = rm -f -TMPFILES = .*.m *.B *.L *.i *.i90 *.l *.s *.mod *.opt - -.SUFFIXES: .F .F90 .H .L .T .f .f90 .h .i .i90 .l .o .s .opt .x - -.f.L: - $(FC) $(FFLAGS) -c -listing $*.f -.f.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f -.f.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f -.f.T: - $(FC) $(FFLAGS) -c -cif $*.f -.f.o: - $(FC) $(FFLAGS) -c $*.f -.f.s: - $(FC) $(FFLAGS) -S $*.f -.f.x: - $(FC) $(FFLAGS) -o $*.x $*.f *.o $(LDFLAGS) -.f90.L: - $(FC) $(FFLAGS) -c -listing $*.f90 -.f90.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f90 -.f90.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f90 -.f90.T: - $(FC) $(FFLAGS) -c -cif $*.f90 -.f90.o: - $(FC) $(FFLAGS) -c $*.f90 -.f90.s: - $(FC) $(FFLAGS) -c -S $*.f90 -.f90.x: - $(FC) $(FFLAGS) -o $*.x $*.f90 *.o $(LDFLAGS) -.F.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F -.F.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F -.F.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F -.F.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F -.F.f: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F > $*.f -.F.i: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F -.F.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F -.F.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F -.F.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F *.o $(LDFLAGS) -.F90.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F90 -.F90.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F90 -.F90.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F90 -.F90.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F90 -.F90.f90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F90 > $*.f90 -.F90.i90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F90 -.F90.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F90 -.F90.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F90 -.F90.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F90 *.o $(LDFLAGS) diff --git a/.travis.yml b/.travis.yml index 03bdff31dc..89a91d34b4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,13 +31,16 @@ jobs: - env: - JOB="x86 Configuration testing" - DO_REGRESSION_TESTS=false - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" + - FCFLAGS_REPRO="-g -O2 -fbacktrace" + - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" + - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - make all + - time make all - echo -en 'travis_fold:end:script.1\\r' - - make -k -s test + - time make -k -s test - make test.summary # NOTE: Code coverage upload is here to reduce load imbalance @@ -48,15 +51,18 @@ jobs: - JOB="x86 Regression testing" - DO_REGRESSION_TESTS=true - REPORT_COVERAGE=true - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} + - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" + - FCFLAGS_REPRO="-g -O2 -fbacktrace" + - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" + - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - make build.regressions + - time make build.regressions - echo -en 'travis_fold:end:script.1\\r' - - make -k -s test.regressions + - time make -k -s test.regressions - make test.summary - if: NOT type = pull_request @@ -77,11 +83,14 @@ jobs: - JOB="ARM64 Configuration testing" - DO_REGRESSION_TESTS=false - DO_REPRO_TESTS=false - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" + - FCFLAGS_REPRO="-g -O2 -fbacktrace" + - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" + - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - make all + - time make all - echo -en 'travis_fold:end:script.1\\r' - - make -k -s test + - time make -k -s test - make test.summary diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000000..a1b1b9118a --- /dev/null +++ b/Makefile.in @@ -0,0 +1,82 @@ +# Makefile template for MOM6 +# +# Previously this would have been generated by mkmf using a template file. +# +# The proposed autoconf build inverts this approach by constructing the +# information previously stored in the mkmf template, such as compiler names +# and flags, and importing the un-templated mkmf output for its rules and +# dependencies. +# +# While this approach does not eliminate our dependency on mkmf, it does +# promises to eliminate our reliance on platform-specific templates, and +# instead allows us to provide a configure script for determining our compilers +# and flags. As a last resort, we provide hooks to override such settings. + +# NOTE: mkmf conventions are close, but not identical, to autoconf. +# +# CC: C compiler +# CXX: C++ compiler +# FC: Fortran compiler (f77 and f90) +# LD: Linker +# +# CPPDEFS: Preprocessor macros +# CPPFLAGS: C preprocessing flags +# CXXFLAGS: C++ preprocessing flags +# FPPFLAGS: Fortran preprocessing flags +# +# CFLAGS: C compiler flags +# FFLAGS: Fortran compiler flags +# LDFLAGS: Linker flags + libraries +# +# NOTES: +# - FPPFLAGS and FFLAGS always appear as a pair, and autoconf does not use +# FPPFLAGS, so FPPFLAGS does not serve much purpose. +# +# - mkmf's FFLAGS does not distinguish between autoconf's fixed-format +# FFLAGS and free-format FCFLAGS. +# +# - LDFLAGS does not distinguish between autoconf's LDFLAGS and LIBS. +# It also places both after the executable rather than just LIBS. +# +# OTHERFLAGS: Additional flags for all languages (C, C++, Fortran) +# OTHER_CFLAGS: Optional C flags +# OTHER_CXXFLAGS: Optional C++ flags +# OTHER_FFLAGS: Optional Fortran flags +# +# TMPFILES: Placeholder for `make clean` deletion (as `make neat`). + +FC = @FC@ +LD = @FC@ + +CPPDEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ @LIBS@ + +# Gather modulefiles +TMPFILES = $(wildcard *.mod) + +include Makefile.mkmf + + +# Delete any files associated with configuration (including the Makefile). +.PHONY: distclean +distclean: clean + # configure output + rm -f config.log + rm -f config.status + rm -f Makefile + # mkmf output + rm -f path_names + rm -f Makefile.mkmf + + +# This deletes all files generated by autoconf, including configure. +# It is more aggressive than automake's maintainer-clean. +# NOTE: Not a standard GNU target, this is for internal use only. +# Don't be surprised if the name changes or if it disappears someday. +.PHONY: ac-clean +ac-clean: distclean + rm -f aclocal.m4 + rm -rf autom4te.cache + rm -f configure diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000000..2da14c1381 --- /dev/null +++ b/configure.ac @@ -0,0 +1,156 @@ +# Autoconf configuration + +# NOTE: +# - We currently do not use a MOM6 version tag, but this would be one option in +# the future: +# [m4_esyscmd_s([git describe])] +# - Another option is `git rev-parse HEAD` for the full hash. +# - We would probably run this inside of a script to avoid the explicit +# dependency on git. + +AC_INIT( + [MOM6], + [ ], + [https://github.com/NOAA-GFDL/MOM6/issues], + [], + [https://github.com/NOAA-GFDL/MOM6]) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([src/core/MOM.F90]) +AC_CONFIG_MACRO_DIR([m4]) + + +# Default to asymmetric grid +# NOTE: --enable is more properly used to add a feature, rather than to select +# a compile-time mode, so this is not exactly being used as intended. +MEM_LAYOUT=${srcdir}/config_src/dynamic +AC_ARG_ENABLE([symmetric], + AS_HELP_STRING([--enable-symmetric], [Enable symmetric grid])) +AS_IF([test "$enable_symmetric" = yes], + [MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric]) + + +## TODO: Support a user-defined memory header +#AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) + + +# Explicitly assume free-form Fortran +AC_LANG(Fortran) +AC_FC_SRCEXT(f90) + + +# Determine MPI compiler wrappers +# NOTE: +# - AX_MPI invokes AC_PROG_FC, often with gfortran, even if the MPI launcher +# does not use gfortran. +# - This can cause standard AC_PROG_FC tests to fail if FCFLAGS is configured +# with flags from another compiler. +# - I do not yet know how to resolve this possible issue. +AX_MPI([], + [AC_MSG_ERROR([Could not find MPI launcher.])]) + + +# Explicitly replace FC and LD with MPI wrappers +# NOTE: This is yet another attempt to manage the potential mismatches between +# FC and MPIFC. Without this step, the tests below would not use MPIFC. +AC_SUBST(FC, $MPIFC) +AC_SUBST(LD, $MPIFC) + +# Confirm that FC can see the Fortran 90 MPI module. +AX_FC_CHECK_MODULE([mpi], + [], [AC_MSG_ERROR([Could not find MPI Fortran module.])]) + + +# netCDF configuration +AC_PATH_PROG([NC_CONFIG], [nc-config]) +AS_IF([test -n "$NC_CONFIG"], + [CPPFLAGS="$CPPFLAGS -I$($NC_CONFIG --includedir)" + FCFLAGS="$FCFLAGS -I$($NC_CONFIG --includedir)" + LDFLAGS="$LDFLAGS -L$($NC_CONFIG --libdir)"], + [AC_MSG_ERROR([Could not find nc-config.])]) + +AX_FC_CHECK_MODULE([netcdf], + [], [AC_MSG_ERROR([Could not find FMS library.])]) +AX_FC_CHECK_LIB([netcdff], [nf_create], [netcdf], + [], [AC_MSG_ERROR([Could not link netcdff library.])] +) + + +# Force 8-byte reals +AX_FC_REAL8 +AS_IF( + [test "$enable_real8" != no], + [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]) + + +# OpenMP configuration +AC_OPENMP +AS_IF( + [test "$enable_openmp" = yes], + [FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS"]) + + +# FMS support + +# Test for fms_mod to verify FMS module access +AX_FC_CHECK_MODULE([fms_mod], [], [ + AS_UNSET([ax_fc_cv_mod_fms_mod]) + AX_FC_CHECK_MODULE([fms_mod], + [AC_SUBST([FCFLAGS], ["-I${srcdir}/deps/include $FCFLAGS"])], + [AC_MSG_ERROR([Could not find fms_mod Fortran module.])], + [-I${srcdir}/deps/include]) +]) + +# Test for fms_init to verify FMS library linking +AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], + [], [ + AS_UNSET([ax_fc_cv_lib_FMS_fms_init]) + AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [ + AC_SUBST([LDFLAGS], ["-L${srcdir}/deps/lib $LDFLAGS"]) + AC_SUBST([LIBS], ["-lFMS $LIBS"]) + ], + [AC_MSG_ERROR([Could not find FMS library.])], + [-L${srcdir}/deps/lib]) + ] +) + + +# Search for mkmf build tools +AC_PATH_PROG([LIST_PATHS], [list_paths]) +AS_IF([test -z "$LIST_PATHS"], [ + AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/deps/bin"]) + AS_IF([test -z "$LIST_PATHS"], + [AC_MSG_ERROR([Could not find list_paths.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/deps/bin"])]) + ] +) + +AC_PATH_PROG([MKMF], [mkmf]) +AS_IF([test -z "$MKMF"], [ + AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/deps/bin"]) + AS_IF([test -z "$MKMF"], + [AC_MSG_ERROR([Could not find mkmf.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/deps/bin"])]) + ] +) + + +# NOTE: MEM_LAYOUT unneeded if we shift to MOM_memory.h.in template +AC_CONFIG_COMMANDS([path_names], + [list_paths -l \ + ${srcdir}/src \ + ${srcdir}/config_src/solo_driver \ + ${srcdir}/config_src/ext* \ + ${MEM_LAYOUT} +], [MEM_LAYOUT=$MEM_LAYOUT]) + + +AC_CONFIG_COMMANDS([Makefile.mkmf], + [mkmf -p MOM6 -m Makefile.mkmf path_names]) + + +# Prepare output +AC_SUBST(CPPFLAGS) +AC_CONFIG_FILES(Makefile) +AC_OUTPUT diff --git a/deps/.gitignore b/deps/.gitignore new file mode 100644 index 0000000000..8cfaa6ebcb --- /dev/null +++ b/deps/.gitignore @@ -0,0 +1,5 @@ +/bin/ +/fms/ +/include/ +/lib/ +/mkmf/ diff --git a/deps/Makefile b/deps/Makefile new file mode 100644 index 0000000000..f0a06071b1 --- /dev/null +++ b/deps/Makefile @@ -0,0 +1,94 @@ +SHELL = bash +.SUFFIXES: + +# FMS build configuration +# TODO: Include FC? +FCFLAGS_FMS ?= + +# Only set FCFLAGS if an argument is provided. +FCFLAGS_ENV = +ifneq ($(FCFLAGS_FMS),) + FCFLAGS_ENV := FCFLAGS="$(FCFLAGS_FMS)" +endif + + +# mkmf, list_paths (GFDL build toolchain) +MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git +MKMF_COMMIT ?= master + +# FMS framework +FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git +FMS_COMMIT ?= 2019.01.03 + + +# 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))) + +FMS_SOURCE = $(call SOURCE,fms/src) + + +#--- +# Rules + +.PHONY: all +all: bin/mkmf bin/list_paths lib/libFMS.a + + +#--- +# mkmf checkout + +bin/mkmf bin/list_paths: mkmf + mkdir -p $(@D) + cp $^/$@ $@ + +mkmf: + git clone $(MKMF_URL) $@ + git -C $@ checkout $(MKMF_COMMIT) + + +#--- +# FMS build + +# NOTE: We emulate the automake `make install` stage by storing libFMS.a to +# ${srcdir}/deps/lib and copying module files to ${srcdir}/deps/include. +# This is a flawed approach, since module files are untracked and could be +# handled more safely, but this is adequate for now. + +# TODO: track *.mod copy? +lib/libFMS.a: fms/build/Makefile + mkdir -p {lib,include} + cd fms/build && $(MAKE) -j ../../lib/libFMS.a + cp fms/build/*.mod include + + +# TODO: Include FC, CC, CFLAGS? +fms/build/Makefile: FC_ENV=$(FCFLAGS_ENV) + +fms/build/Makefile: fms/src/configure bin/mkmf bin/list_paths + mkdir -p fms/build + cd $(@D) && $(FC_ENV) ../src/configure --srcdir=../src + + +# TODO: Track m4 macros? +fms/src/configure: fms/src configure.fms.ac Makefile.fms.in $(FMS_SOURCE) + cp configure.fms.ac $ +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ(2.50) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI From f6248cb7c68848acc09cd8a16e03d1253c29791c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 11:04:51 -0400 Subject: [PATCH 210/256] Minor gitignore update --- .gitignore | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/.gitignore b/.gitignore index 8a79222df4..ccaecbbead 100644 --- a/.gitignore +++ b/.gitignore @@ -2,14 +2,19 @@ *.swp *~ html -*.log + + +# Build output +*.o +*.mod MOM6 + # Autoconf -/aclocal.m4 -/autom4te.cache/ -/config.log -/config.status -/configure +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure /Makefile -/Makefile.mkmf +Makefile.mkmf From df12b66bcd70fabdde9f89236bd0feebe0c381cb Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Wed, 2 Sep 2020 11:46:19 -0400 Subject: [PATCH 211/256] WARNING changed to FATAL error. The error message has been modified. --- config_src/solo_driver/MOM_surface_forcing.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 8db310893b..7e56bd520c 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -303,9 +303,9 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! calls to various buoyancy forcing options if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then - call MOM_error(WARNING, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& - "Changed to VARIABLE_BUOYFORCE = True") - CS%variable_buoyforce = .true. + call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Otherwise, this can lead to diverging soultions when a simulation "//& + "is continued using a restart file.") endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & From b89c6403aca7c40ec6d44fddc587984aa1703ce3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 12:04:47 -0400 Subject: [PATCH 212/256] Update MOM_surface_forcing.F90 --- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 7e56bd520c..3d8b398516 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -304,7 +304,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! calls to various buoyancy forcing options if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& - "Otherwise, this can lead to diverging soultions when a simulation "//& + "Otherwise, this can lead to diverging solutions when a simulation "//& "is continued using a restart file.") endif From 12a83f79d1c36424b8eac934ac806380b4582842 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 12:12:50 -0400 Subject: [PATCH 213/256] Autoconf: Coverage and target LDFLAGS fixes Minor fixes which include the FCFLAGS coverage flag into LDFLAGS for gcov builds, as well as properly moving the target -L flag out of FCFLAGS and into LDFLAGS. --- .testing/Makefile | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index dd0db892ac..0d9f9d84e2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -17,7 +17,7 @@ FCFLAGS_DEBUG ?= -g -O0 FCFLAGS_REPRO ?= -g -O2 FCFLAGS_INIT ?= FCFLAGS_COVERAGE ?= -# Addtional notes: +# Additional notes: # # - The default values are simple, minimalist flags, supported by nearly all # compilers and meant to represent GFDL's canonical DEBUG and REPRO builds. @@ -137,11 +137,14 @@ BUILD_TARGETS = MOM6 Makefile path_names # Conditionally build symmetric with coverage support COVERAGE=$(if $(REPORT_COVERAGE),"$(FCFLAGS_COVERAGE)",) +# Explicit FMS link to target build # TODO: We should probably build TARGET with the FMS that it was configured # to use. But for now we use the same FMS over all builds. -FCFLAGS_TARGET_FMS = -I../../../deps/include -L../../../deps/lib +FCFLAGS_TARGET_FMS = -I../../../deps/include +LDFLAGS_TARGET_FMS = -L../../../deps/lib PATH_TARGET = PATH="${PATH}:../../../deps/bin" + # Define the build targets in terms of the traditional DEBUG/REPRO/etc labels FCFLAGS_SYMMETRIC = ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT)$(COVERAGE),) @@ -155,6 +158,8 @@ ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT),) FCFLAGS_TARGET := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_TARGET_FMS)" FCFLAGS_ASYMMETRIC := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" FCFLAGS_OPENMP := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" +else + FCFLAGS_TARGET := FCFLAGS="$(FCFLAGS_TARGET_FMS)" endif FCFLAGS_REPRO_RUN = @@ -162,13 +167,19 @@ ifneq ($(FCFLAGS_REPRO),) FCFLAGS_REPRO_RUN := FCFLAGS="$(FCFLAGS_REPRO)" endif +LDFLAGS_SYMMETRIC = +ifneq ($(COVERAGE),) + LDFLAGS_SYMMETRIC := LDFLAGS="$(COVERAGE)" +endif +LDFLAGS_TARGET := LDFLAGS="$(LDFLAGS_TARGET_FMS)" + # Environment variable configuration -build/symmetric/Makefile: FC_ENV=$(FCFLAGS_SYMMETRIC) +build/symmetric/Makefile: FC_ENV=$(FCFLAGS_SYMMETRIC) $(LDFLAGS_SYMMETRIC) build/asymmetric/Makefile: FC_ENV=$(FCFLAGS_ASYMMETRIC) build/repro/Makefile: FC_ENV=$(FCFLAGS_REPRO_RUN) build/openmp/Makefile: FC_ENV=$(FCFLAGS_OPENMP) -build/target/Makefile: FC_ENV=$(FCFLAGS_TARGET) $(PATH_TARGET) +build/target/Makefile: FC_ENV=$(FCFLAGS_TARGET) $(LDFLAGS_TARGET) $(PATH_TARGET) # Configure script flags From bde93fb2502745916c8b69795037f6c5195aaee1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 14:07:50 -0400 Subject: [PATCH 214/256] Testing: Adding message to report codecov report upload --- .testing/Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 0d9f9d84e2..a15994a58b 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -298,6 +298,7 @@ run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) # Color highlights for test results RED=\033[0;31m GREEN=\033[0;32m +MAGENTA=\033[0;35m RESET=\033[0m DONE=${GREEN}DONE${RESET} @@ -391,7 +392,8 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ > work/$$*/codecov.$(1).out \ - 2> work/$$*/codecov.$(1).err ; \ + 2> work/$$*/codecov.$(1).err \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}"; \ fi endef From 2fe58383ad2c6183581686d3e9941a0c4576b2d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Sep 2020 16:34:38 -0400 Subject: [PATCH 215/256] (*)Reduce size of GV%Rlay and improve error handling Reduced the size of GV%Rlay to GV%ke, befitting a layer variable, and added code to issue error messages or appropriately handle cases with very few layers that would have led to segmentation faults without error handling. This includes explicitly setting argument array sizes in various set_coord subroutines, and correcting the descriptions of some EOS_type arguments. All answers in the MOM6-examples regression suite are bitwise identical, but there may be some answer changes in cases that should not have worked previously. This PR addresses MOM6 issue #966, which might now be closed. --- src/ALE/MOM_regridding.F90 | 21 ++- src/core/MOM_verticalGrid.F90 | 3 +- .../MOM_coord_initialization.F90 | 153 +++++++++--------- .../MOM_state_initialization.F90 | 9 +- src/tracer/MOM_tracer_hor_diff.F90 | 19 +-- src/user/BFB_initialization.F90 | 15 +- src/user/ISOMIP_initialization.F90 | 2 +- src/user/Neverworld_initialization.F90 | 3 +- src/user/adjustment_initialization.F90 | 9 +- src/user/benchmark_initialization.F90 | 10 +- src/user/user_initialization.F90 | 23 ++- 11 files changed, 138 insertions(+), 129 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 889e10e32d..2a77cb06fe 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -375,6 +375,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 + if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//& + "in FILE "//trim(filename)//" requires at least 2 target interface values.") if (CS%regridding_scheme == REGRIDDING_RHO) then allocate(rho_target(ke+1)) call MOM_read_data(trim(fileName), trim(varName), rho_target) @@ -392,7 +394,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m allocate(dz(ke)) call MOM_read_data(trim(fileName), trim(varName), dz) endif - if (main_parameters .and. ke/=GV%ke) then + if (main_parameters .and. (ke/=GV%ke)) then call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Mismatch in number of model levels and "'//trim(string)//'".') endif @@ -2016,17 +2018,22 @@ end subroutine setCoordinateResolution !> Set target densities based on the old Rlay variable subroutine set_target_densities_from_GV( GV, US, CS ) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical 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 type(regridding_CS), intent(inout) :: CS !< Regridding control structure ! Local variables integer :: k, nz nz = CS%nk - CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) - CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) - do k = 2,nz - CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) - enddo + if (nz == 1) then ! Set a broad range of bounds. Regridding may not be meaningful in this case. + CS%target_density(1) = 0.0 + CS%target_density(2) = 2.0*GV%Rlay(1) + else + CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) + CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) + do k=2,nz + CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) + enddo + endif CS%target_density_set = .true. end subroutine set_target_densities_from_GV diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 6e65d38c8a..7495e0033b 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -174,8 +174,7 @@ subroutine verticalGridInit( param_file, GV, US ) allocate( GV%sInterface(nk+1) ) allocate( GV%sLayer(nk) ) allocate( GV%g_prime(nk+1) ) ; GV%g_prime(:) = 0.0 - ! The extent of Rlay should be changed to nk? - allocate( GV%Rlay(nk+1) ) ; GV%Rlay(:) = 0.0 + allocate( GV%Rlay(nk) ) ; GV%Rlay(:) = 0.0 end subroutine verticalGridInit diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 5b2bd7130f..c1ec788836 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -105,6 +105,10 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & "Unrecognized coordinate setup"//trim(config)) end select + ! There are nz+1 values of g_prime because it is an interface field, but the value at the bottom + ! should not matter. This is here just to avoid having an uninitialized value in some output. + GV%g_prime(nz+1) = 10.0*GV%g_Earth + if (debug) call chksum(US%R_to_kg_m3*GV%Rlay(:), "MOM_initialize_coord: Rlay ", 1, nz) if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) @@ -123,13 +127,13 @@ end subroutine MOM_initialize_coord !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + 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 [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]. @@ -157,13 +161,14 @@ end subroutine set_coord_from_gprime !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + 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 [L2 Z-1 T-2 ~> m s-2]. real :: Rlay_Ref! The surface layer's target density [R ~> kg m-3]. @@ -184,14 +189,14 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) - g_prime(1) = g_fs Rlay(1) = Rlay_Ref do k=2,nz - Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) + Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) enddo ! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -199,17 +204,17 @@ 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) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer selecting the equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + 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 @@ -232,7 +237,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state 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) - ! + ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo @@ -250,17 +255,15 @@ 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) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref @@ -299,17 +302,15 @@ 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) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref @@ -357,6 +358,9 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta "The reduced gravity at the free surface.", units="m s-2", & 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) + if ((GV%nk_rho_varies > 0) .and. (nz < GV%nk_rho_varies+2)) & + call MOM_error(FATAL, "set_coord_from_TS_range requires that NZ >= NKML+NKBL+2.") + k_light = GV%nk_rho_varies + 1 ! Set T0(k) to range from T_LIGHT to T_DENSE, and simliarly for S0(k). @@ -376,20 +380,20 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + 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_range ! Sets the layer densities (Rlay) and the interface reduced gravities (g) from data in file. subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + 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 [L2 Z-1 T-2 ~> m s-2]. integer :: k, nz @@ -435,13 +439,13 @@ end subroutine set_coord_from_file !! to the bottom defined by the parameter RLAY_RANGE !! (defaulting to 2.0 if not defined) subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) - 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 - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + 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 character(len=40) :: mdl = "set_coord_linear" ! This subroutine real :: Rlay_ref, Rlay_range, g_fs @@ -464,12 +468,12 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) ! surface interface has density Rlay_ref and the bottom ! is Rlay_range larger do k=1,nz - Rlay(k) = Rlay_Ref + RLay_range*((real(k)-0.5)/real(nz)) + Rlay(k) = Rlay_Ref + RLay_range*((real(k)-0.5)/real(nz)) enddo ! These statements set the interface reduced gravities. g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -479,13 +483,12 @@ end subroutine set_coord_linear !! This is for use only in ALE mode where Rlay should not be used and g_prime(1) alone !! might be used. subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) - 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, - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + 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 [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9f505325bf..de33409fed 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1558,7 +1558,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density reference pressure !! [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -2335,7 +2335,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! Rb contains the layer interface densities allocate(Rb(nz+1)) 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) + Rb(1) = 0.0 + if (nz>1) then + Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + else + Rb(nz+1) = 2.0 * GV%Rlay(1) + endif nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 53ed8881e3..43ede7cff5 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -727,11 +727,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Use bracketing and bisection to find the k-level that the densest of the ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,nkmb,G,GV,Rml_max,max_kRho) & -!$OMP private(k_min,k_max,k_test) + !$OMP parallel do default(shared) private(k_min,k_max,k_test) do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then - if (Rml_max(i,j) > GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 - elseif (Rml_max(i,j) <= GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 + if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 + elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else k_min = nkmb+2 ; k_max = nz do @@ -754,10 +753,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & if (PEmax_kRho > nz) PEmax_kRho = nz ! PEmax_kRho could have been nz+1. h_exclude = 10.0*(GV%Angstrom_H + GV%H_subroundoff) -!$OMP parallel default(none) shared(is,ie,js,je,nkmb,G,GV,h,h_exclude,num_srt,k0_srt, & -!$OMP rho_srt,h_srt,PEmax_kRho,k_end_srt,rho_coord,max_srt) & -!$OMP private(ns,tmp,itmp) -!$OMP do + !$OMP parallel default(shared) private(ns,tmp,itmp) + !$OMP do do j=js-1,je+1 do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then if (h(i,j,k) > h_exclude) then @@ -778,7 +775,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo ! Sort each column by increasing density. This should already be close, ! and the size of the arrays are small, so straight insertion is used. -!$OMP do + !$OMP do do j=js-1,je+1; do i=is-1,ie+1 do k=2,num_srt(i,j) ; if (rho_srt(i,k,j) < rho_srt(i,k-1,j)) then ! The last segment needs to be shuffled earlier in the list. @@ -789,12 +786,12 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo endif ; enddo enddo ; enddo -!$OMP do + !$OMP do do j=js-1,je+1 max_srt(j) = 0 do i=is-1,ie+1 ; max_srt(j) = max(max_srt(j), num_srt(i,j)) ; enddo enddo -!$OMP end parallel + !$OMP end parallel do j=js,je k_size = max(2*max_srt(j),1) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 9e8f612a35..1c5ee016ae 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -36,14 +36,13 @@ module BFB_initialization !! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers !! and linearly interpolated for the intermediate layers. subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) - real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(NKMEM_), intent(out) :: g_prime !< The reduced gravity at - !! each interface [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure ! Local variables real :: drho_dt, SST_s, T_bot, rho_top, rho_bot integer :: k, nz diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 0a3cfb3fbe..d125495d7f 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -370,7 +370,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi if (fit_salin) then ! A first guess of the layers' salinity. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) enddo ! Refine the guesses for each layer. do itt=1,6 diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 5a21966c9d..d019854310 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -248,8 +248,7 @@ subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_stat type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. ! Local variables diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 6dde9c68ef..0ceaabbec7 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -125,8 +125,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read e0(k) = -G%max_depth * (real(k-1) / real(nz)) enddo endif - target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) - target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + if (nz > 1) then + target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) + target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + else ! This might not be needed, but it avoids segmentation faults if nz=1. + target_values(1) = 0.0 + target_values(nz+1) = 2.0 * GV%Rlay(1) + endif do k = 2,nz target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) enddo diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index e32c8b9e41..cc82ea6761 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -91,8 +91,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -217,16 +216,15 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature !! that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being !! initialized. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for !! model parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 55c609802e..a5d0fc90f7 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -38,17 +38,15 @@ module user_initialization !> Set vertical coordinates. subroutine USER_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(:), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity at - !! each interface [L2 Z-1 T-2 ~> m s-2]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure call MOM_error(FATAL, & "USER_initialization.F90, USER_set_coord: " // & @@ -144,8 +142,7 @@ subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state, jus type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will only !! read parameters without changing T & S. From 1d717f57013dffae216297d14cf9b2a0f12957d2 Mon Sep 17 00:00:00 2001 From: jskenigson Date: Wed, 2 Sep 2020 14:52:27 -0600 Subject: [PATCH 216/256] Update MOM_PressureForce_FV.F90 mn_T = 0 so remove subtraction of mn_T^2 in SGS temperature variance --- src/core/MOM_PressureForce_FV.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 942c29854e..fc47ef11e5 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -542,7 +542,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. - tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2 - mn_T*mn_T) + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif From ff451d700eaf5a82d39ef2ab755711c6191a7118 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 17:50:44 -0400 Subject: [PATCH 217/256] Travis: Environment variable globals; Timer log Several build environment variables were redefined globally to be used across all jobs, rather than repeating over every job. The timer output was also redefined to be single line, rather than four, to reduce logging output. --- .travis.yml | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/.travis.yml b/.travis.yml index 89a91d34b4..0dc3d1edf1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,6 +17,15 @@ addons: - python3 python3-dev python3-venv python3-pip - bc +# Environment variables +env: + global: + - TIMEFORMAT: "Time: %lR (user: %lU, sys: %lS)" + - FCFLAGS_DEBUG: "-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" + - FCFLAGS_REPRO: "-g -O2 -fbacktrace" + - FCFLAGS_INIT: "-finit-real=snan -finit-integer=2147483647 -finit-derived" + - FCFLAGS_COVERAGE: "--coverage" + jobs: include: - env: JOB="Code compliance" @@ -29,12 +38,8 @@ jobs: - test ! -s doxy_errors - env: - - JOB="x86 Configuration testing" + - JOB="x86 verification testing" - DO_REGRESSION_TESTS=false - - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" - - FCFLAGS_REPRO="-g -O2 -fbacktrace" - - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" - - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' @@ -53,10 +58,6 @@ jobs: - REPORT_COVERAGE=true - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} - - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" - - FCFLAGS_REPRO="-g -O2 -fbacktrace" - - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" - - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' @@ -70,7 +71,6 @@ jobs: - JOB="Coverage upload" - REPORT_COVERAGE=true - DO_REGRESSION_TESTS=false - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' @@ -80,13 +80,9 @@ jobs: - arch: arm64 env: - - JOB="ARM64 Configuration testing" + - JOB="ARM64 verification testing" - DO_REGRESSION_TESTS=false - DO_REPRO_TESTS=false - - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" - - FCFLAGS_REPRO="-g -O2 -fbacktrace" - - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" - - FCFLAGS_COVERAGE="--coverage" script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' From d186229a4389feabaa4ba2b57e171f3622aae34e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 18:55:06 -0400 Subject: [PATCH 218/256] Travis: Fixing global environment variables --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 0dc3d1edf1..3fd729f8d1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,11 +20,11 @@ addons: # Environment variables env: global: - - TIMEFORMAT: "Time: %lR (user: %lU, sys: %lS)" - - FCFLAGS_DEBUG: "-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" - - FCFLAGS_REPRO: "-g -O2 -fbacktrace" - - FCFLAGS_INIT: "-finit-real=snan -finit-integer=2147483647 -finit-derived" - - FCFLAGS_COVERAGE: "--coverage" + - TIMEFORMAT="Time: %lR (user: %lU, sys: %lS)" + - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" + - FCFLAGS_REPRO="-g -O2 -fbacktrace" + - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" + - FCFLAGS_COVERAGE="--coverage" jobs: include: From 5aa08635ced42046ae5a56ec69d01cb4ba3c5552 Mon Sep 17 00:00:00 2001 From: jkenigson Date: Wed, 2 Sep 2020 17:57:42 -0600 Subject: [PATCH 219/256] Updated MOM_thickness_diffuse to use the deterministic parameterization of the SGS temperature variance --- .../lateral/MOM_thickness_diffuse.F90 | 52 ++++++++++++++----- 1 file changed, 38 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b59ab34c91..d338785406 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -158,6 +158,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -746,16 +748,38 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then !$OMP do do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! SGS variance in i-direction [degC2] - dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 - ! SGS variance in j-direction [degC2] - dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 - Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) - enddo ; enddo ; enddo + !! SGS variance in i-direction [degC2] + !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ! ) * G%dxT(i,j) * 0.5 )**2 + !! SGS variance in j-direction [degC2] + !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ! ) * G%dyT(i,j) * 0.5 )**2 + !Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + ! This block does a thickness weighted variance calculation and helps control for + ! extreme gradients along layers which are vanished against topography. It is + ! still a poor approximation in the interior when coordinates are strongly tilted. + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff + mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + ! Mean of T + Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) + Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + ! Adjust T vectors to have zero mean + Tl(:) = Tl(:) - mn_T ; mn_T = 0. + ! Variance of T + mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + ! Variance should be positive but round-off can violate this. Calculating + ! variance directly would fix this but requires more operations. + Tsgs2(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) + enddo ; enddo ; enddo endif !$OMP do do j=js-1,je+1 @@ -846,8 +870,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdiA = drdiA + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) - drdiB = drdiB + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + drdiA = drdiA + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) endif if (find_work) drdi_u(I,k) = drdiB @@ -1111,8 +1135,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdjA = drdjA + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) - drdjB = drdjB + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + drdjA = drdjA + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) endif if (find_work) drdj_v(i,k) = drdjB From b155bf36b607792c045fcd823095f77981cff8a7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Sep 2020 21:41:27 -0400 Subject: [PATCH 220/256] (*)Correct the use of memory macros for arguments Corrected a number of memory macros that would cause MOM6 to give the wrong answers and probably lead to segmentation faults if global indexing were enabled. Macros like NIMEM_ are intended to be used to support static or dynamic memory in the declaration of ALLOCABLE_ arrays, but instead were being used to define the sizes of arguments in some routines, which would cause these arrays to start at 1, not G%isd, inside these routines. All answers in the MOM6-examples test suite are bitwise identical. --- src/tracer/MOM_tracer_flow_control.F90 | 34 +++++++++++++------------- src/tracer/dye_example.F90 | 8 +++--- src/user/BFB_initialization.F90 | 6 ++--- src/user/SCM_CVMix_tests.F90 | 18 +++++++------- 4 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 5e9f01c7be..4c7c27c7e6 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -264,7 +264,8 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to @@ -332,15 +333,15 @@ end subroutine tracer_flow_control_init !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, CS) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: Chl_array !< The array in which to store the model's !! Chlorophyll-A concentrations in mg m-3. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. if (CS%use_MOM_generic_tracer) then - call MOM_generic_tracer_get('chl','field',Chl_array, CS%MOM_generic_tracer_CSp) + call MOM_generic_tracer_get('chl', 'field', Chl_array, CS%MOM_generic_tracer_CSp) else call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & "that is unable to provide a sensible model-based value.\n"// & @@ -377,25 +378,24 @@ end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & debug, evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Layer thickness before entrainment !! [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Layer thickness after entrainment !! [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< an array to which the amount of !! fluid entrained from the layer above during this call !! will be added [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< an array to which the amount of !! fluid entrained from the layer below during this call !! will be added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to !! any possible forcing fields. !! Unused fields have NULL ptrs. - real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + 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 [T ~> s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. type(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. @@ -542,12 +542,12 @@ end subroutine call_tracer_column_fns subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & num_stocks, stock_index, got_min_max, global_min, global_max, & xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer !! on the current PE, usually in kg x concentration [kg conc]. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. @@ -725,9 +725,9 @@ end subroutine store_stocks 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] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 5f2f139899..cd17415b21 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -189,7 +189,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -326,11 +326,11 @@ end subroutine dye_tracer_column_physics !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units [kg conc]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of + !! each tracer, in kg times concentration units [kg conc]. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a !! previous call to register_dye_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 9e8f612a35..af77401266 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -86,13 +86,13 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure - real, dimension(NIMEM_, NJMEM_, NKMEM_), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta, in depth units [Z ~> m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, in depth units [Z ~> m]. 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 :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. real :: slat, wlon, lenlat, lenlon, nlat real :: max_damping ! The maximum damping rate [T-1 ~> s-1] diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 1bb1b9555e..9f36e7033d 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -53,15 +53,15 @@ module SCM_CVMix_tests !> Initializes temperature and salinity for the SCM CVMix test example subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read_params) - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: T !< Potential temperature [degC] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: S !< Salinity [psu] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(ocean_grid_type), intent(in) :: 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(param_file_type), intent(in) :: param_file !< Input parameter structure - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [psu] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + logical, optional, intent(in) :: just_read_params !< If present and true, this call + !! will only read parameters without changing h. ! Local variables real :: UpperLayerTempMLD !< Upper layer Temp MLD thickness [Z ~> m]. real :: UpperLayerSaltMLD !< Upper layer Salt MLD thickness [Z ~> m]. From 751faaa2b26ceee8393b74228be684e6fac26a6f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 3 Sep 2020 18:15:17 -0400 Subject: [PATCH 221/256] OBC: segment parser refactoring The segment configuration parser was encountering problems with GFortran 10.2, where the `fields` array update was being removed by the -O2 optimizer. In fact, the `parse_segment_data_str` function was doing two separate operations, where the first call would determine the number of fields and save their names into an array, and the second call would parse the data contents of each input field. The presence of optional arguments were used to effectively select the preferred operation. It is possible that the presence of these optional arguments was interfering with optimization, causing the removal of the `fields` update. While this is most likely a bug in the GFortran compiler, we address the problem by instead splitting this function into two independent functions, which allows us to remove the optional arguments. When split, the function appears to work correctly under O2 optimization. --- src/core/MOM_open_boundary.F90 | 149 +++++++++++++++------------------ 1 file changed, 66 insertions(+), 83 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 37ebeda1fa..d0f7caa0c2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -669,7 +669,7 @@ subroutine initialize_segment_data(G, OBC, PF) call MOM_error(FATAL, mesg) endif - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + call parse_segment_manifest_str(trim(segstr), num_fields, fields) if (num_fields == 0) then call MOM_mesg('initialize_segment_data: num_fields = 0') cycle ! cycle to next segment @@ -690,7 +690,8 @@ subroutine initialize_segment_data(G, OBC, PF) JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & + value, filename, fieldname) if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data @@ -1344,92 +1345,73 @@ integer function interpret_int_expr(string, imax) end function interpret_int_expr end subroutine parse_segment_str -!> Parse an OBC_SEGMENT_%%%_DATA string - subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed - character(len=*), optional, intent(out) :: filenam !< The name of the input file if using "file" method - character(len=*), optional, intent(out) :: fieldnam !< The name of the variable in the input file if using - !! "file" method - real, optional, intent(out) :: value !< A constant value if using the "value" method - character(len=*), dimension(MAX_OBC_FIELDS), & - optional, intent(out) :: fields !< List of fieldnames for each segment - integer, optional, intent(out) :: num_fields !< The number of fields in the segment data - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - nfields=0 - continue=.true. - dbg=.false. - if (PRESENT(debug)) dbg=debug +!> Parse an OBC_SEGMENT_%%%_DATA string and determine its fields +subroutine parse_segment_manifest_str(segment_str, num_fields, fields) + character(len=*), intent(in) :: segment_str !< A string in form of + !< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(out) :: num_fields !< The number of fields in the segment data + character(len=*), dimension(MAX_OBC_FIELDS), intent(out) :: fields + !< List of fieldnames for each segment - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields=nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo - - if (PRESENT(fields)) then - do n=1,nfields - fields(n) = flds(n) - enddo - endif + ! Local variables + character(len=128) :: word1, word2 + + num_fields = 0 + do + word1 = extract_word(segment_str, ',', num_fields+1) + if (trim(word1) == '') exit + num_fields = num_fields + 1 + word2 = extract_word(word1, '=', 1) + fields(num_fields) = trim(word2) + enddo +end subroutine parse_segment_manifest_str - if (PRESENT(num_fields)) then - num_fields=nfields - return - endif - m=0 - if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m=n - exit - endif - enddo - if (m==0) then - call abort() - endif +!> Parse an OBC_SEGMENT_%%%_DATA string +subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldname) + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(in) :: idx !< Index of segment_str record + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + character(len=*), intent(out) :: filename !< The name of the input file if using "file" method + character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using + !! "file" method + real, optional, intent(out) :: value !< A constant value if using the "value" method - ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) - word1 = extract_word(word3,':',1) -! if (trim(word1) == '') exit - word2 = extract_word(word1,'=',1) - if (trim(word2) == trim(var)) then - method=trim(extract_word(word1,'=',2)) - lword=len_trim(method) - if (method(lword-3:lword) == 'file') then - ! raise an error id filename/fieldname not in argument list - word1 = extract_word(word3,':',2) - filenam = extract_word(word1,'(',1) - fieldnam = extract_word(word1,'(',2) - lword=len_trim(fieldnam) - fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - value=-999. - elseif (method(lword-4:lword) == 'value') then - filenam = 'none' - fieldnam = 'none' - word1 = extract_word(word3,':',2) - lword=len_trim(word1) - read(word1(1:lword),*,end=986,err=987) value - endif - endif + ! Local variables + character(len=128) :: word1, word2, word3, method + integer :: lword + + ! Process first word which will start with the fieldname + word3 = extract_word(segment_str, ',', idx) + word1 = extract_word(word3, ':', 1) + !if (trim(word1) == '') exit + word2 = extract_word(word1, '=', 1) + if (trim(word2) == trim(var)) then + method = trim(extract_word(word1, '=', 2)) + lword = len_trim(method) + if (method(lword-3:lword) == 'file') then + ! raise an error id filename/fieldname not in argument list + word1 = extract_word(word3, ':', 2) + filename = extract_word(word1, '(', 1) + fieldname = extract_word(word1, '(', 2) + lword = len_trim(fieldname) + fieldname = fieldname(1:lword-1) ! remove trailing parenth + value = -999. + elseif (method(lword-4:lword) == 'value') then + filename = 'none' + fieldname = 'none' + word1 = extract_word(word3, ':', 2) + lword = len_trim(word1) + read(word1(1:lword), *, end=986, err=987) value endif + endif - return - 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) - 987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) - - end subroutine parse_segment_data_str + return +986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) +987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) +end subroutine parse_segment_data_str !> Parse all the OBC_SEGMENT_%%%_DATA strings again @@ -1458,12 +1440,13 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) call get_param(PF, mdl, segnam, segstr) if (segstr == '') cycle - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + call parse_segment_manifest_str(trim(segstr), num_fields, fields) if (num_fields == 0) cycle ! At this point, just search for TEMP and SALT as tracers 1 and 2. do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & + value, filename, fieldname) if (trim(filename) /= 'none') then if (fields(m) == 'TEMP') then if (segment%is_E_or_W_2) then From edff25e02a920a8058af7b8d40ced0311b121912 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 4 Sep 2020 18:09:16 -0400 Subject: [PATCH 222/256] Rename intermediate variable in Stanley PGF parameterization - A variable was poorly named and also changed units mid-stream. The newly named variable now only has the same units ever. --- src/core/MOM_PressureForce_FV.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 942c29854e..03d2c807a7 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -480,8 +480,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] + real :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: hl(5) ! Copy of local stencil of H [H ~> m] + real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -529,17 +532,16 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff - mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) ! Mean of T Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. ! Variance of T mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2 - mn_T*mn_T) From 4ac556c63443b59999570d07437db31a2d4d0bd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Sep 2020 08:47:02 -0400 Subject: [PATCH 223/256] Properly set vertex_shear in set_diffusivity_init Always call kappa_shear_at_vertex so that the Vertex_shear element of the control structure for the MOM_set_diffusivity module is always actively set. It had previously been initialized only if USE_JACKSON_PARAM is true, which led to the issues reported in MOM6 issue #1201. Also clarified or corrected some of the comments in MOM_kappa_shear. All answers will be bitwise identical in all cases that worked previously, and this PR corrects the problems noted in issue #1201, which can closed once it is accepted. --- .../vertical/MOM_kappa_shear.F90 | 22 ++++++++++++------- .../vertical/MOM_set_diffusivity.F90 | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 3ba3d2b74c..9705b36543 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -656,6 +656,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & optional, intent(out) :: dz_Int_1d !< The extent of a finite-volume space surrounding an interface, !! as used in calculating kappa and TKE [Z ~> m]. + ! Local variables real, dimension(nzc) :: & u, & ! The zonal velocity after a timestep of mixing [L T-1 ~> m s-1]. v, & ! The meridional velocity after a timestep of mixing [L T-1 ~> m s-1]. @@ -1231,7 +1232,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real, dimension(nz+1), optional, & intent(out) :: local_src !< The sum of all local sources for kappa, !! [T-1 ~> s-1]. -! This subroutine calculates new, consistent estimates of TKE and kappa. + ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & @@ -1756,7 +1757,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & end subroutine find_kappa_tke -!> This subroutineinitializesthe parameters that regulate shear-driven mixing +!> This subroutine initializes the parameters that regulate shear-driven mixing function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1943,25 +1944,30 @@ end function kappa_shear_init !! parameterization will be used without needing to duplicate the log entry. logical function kappa_shear_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Reads the parameter "USE_JACKSON_PARAM" and returns state. + + ! Local variables character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! This function reads the parameter "USE_JACKSON_PARAM" and returns its value. call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_is_used, & default=.false., do_not_log=.true.) end function kappa_shear_is_used -!> This function indicates to other modules whether the Jackson et al shear mixing -!! parameterization will be used without needing to duplicate the log entry. +!> This function indicates to other modules whether the Jackson et al shear mixing parameterization +!! will be used at the vertices without needing to duplicate the log entry. It returns false if +!! the Jackson et al scheme is not used or if it is used via calculations at the tracer points. logical function kappa_shear_at_vertex(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Reads the parameter "USE_JACKSON_PARAM" and returns state. - character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! Local variables + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. logical :: do_kappa_shear + ! This function returns true only if the parameters "USE_JACKSON_PARAM" and "VERTEX_SHEAR" are both true. + + kappa_shear_at_vertex = .false. call get_param(param_file, mdl, "USE_JACKSON_PARAM", do_kappa_shear, & default=.false., do_not_log=.true.) - kappa_shear_at_vertex = .false. if (do_Kappa_Shear) & call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & "If true, do the calculations of the shear-driven mixing "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 42babae7d8..b81cf62631 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2219,7 +2219,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "Bryan-Lewis and internal tidal dissipation are both enabled. Choose one.") CS%useKappaShear = kappa_shear_init(Time, G, GV, US, param_file, CS%diag, CS%kappaShear_CSp) - if (CS%useKappaShear) CS%Vertex_Shear = kappa_shear_at_vertex(param_file) + CS%Vertex_Shear = kappa_shear_at_vertex(param_file) if (CS%useKappaShear) & id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) From 2a5e3005ed07df4a91de72060c2f7500e0fd83cb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 9 Sep 2020 14:07:57 -0400 Subject: [PATCH 224/256] Moving autoconf tools to /ac directory Because autoconf can cause fear and anger in some users, the configuration files have now been delegated to a subdirectory, ac, which can be invoked from an arbitrary directory. This required some unconventional constructs in the file, but they have luckily been relegated to a few introductory statements, and the bulk of the code is unchanged. The only pervasive change is the explicit references to the ac directory, particularly ac/deps. .testing also had to be updated to accommodate the autoconf changes. --- .testing/Makefile | 21 ++++++------ Makefile.in => ac/Makefile.in | 0 configure.ac => ac/configure.ac | 40 ++++++++++++++++------- {deps => ac/deps}/.gitignore | 0 {deps => ac/deps}/Makefile | 0 {deps => ac/deps}/Makefile.fms.in | 0 {deps => ac/deps}/configure.fms.ac | 0 {m4 => ac/m4}/ax_fc_allow_arg_mismatch.m4 | 0 {m4 => ac/m4}/ax_fc_allow_invalid_boz.m4 | 0 {m4 => ac/m4}/ax_fc_check_lib.m4 | 0 {m4 => ac/m4}/ax_fc_check_module.m4 | 0 {m4 => ac/m4}/ax_fc_cray_pointer.m4 | 0 {m4 => ac/m4}/ax_fc_real8.m4 | 0 {m4 => ac/m4}/ax_mpi.m4 | 0 14 files changed, 40 insertions(+), 21 deletions(-) rename Makefile.in => ac/Makefile.in (100%) rename configure.ac => ac/configure.ac (75%) rename {deps => ac/deps}/.gitignore (100%) rename {deps => ac/deps}/Makefile (100%) rename {deps => ac/deps}/Makefile.fms.in (100%) rename {deps => ac/deps}/configure.fms.ac (100%) rename {m4 => ac/m4}/ax_fc_allow_arg_mismatch.m4 (100%) rename {m4 => ac/m4}/ax_fc_allow_invalid_boz.m4 (100%) rename {m4 => ac/m4}/ax_fc_check_lib.m4 (100%) rename {m4 => ac/m4}/ax_fc_check_module.m4 (100%) rename {m4 => ac/m4}/ax_fc_cray_pointer.m4 (100%) rename {m4 => ac/m4}/ax_fc_real8.m4 (100%) rename {m4 => ac/m4}/ax_mpi.m4 (100%) diff --git a/.testing/Makefile b/.testing/Makefile index a15994a58b..c91dcc0a97 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -31,7 +31,7 @@ FCFLAGS_COVERAGE ?= #--- # Dependencies -DEPS = ../deps +DEPS = ../ac/deps # mkmf, list_paths (GFDL build toolchain) LIST_PATHS := $(DEPS)/bin/list_paths @@ -140,9 +140,9 @@ COVERAGE=$(if $(REPORT_COVERAGE),"$(FCFLAGS_COVERAGE)",) # Explicit FMS link to target build # TODO: We should probably build TARGET with the FMS that it was configured # to use. But for now we use the same FMS over all builds. -FCFLAGS_TARGET_FMS = -I../../../deps/include -LDFLAGS_TARGET_FMS = -L../../../deps/lib -PATH_TARGET = PATH="${PATH}:../../../deps/bin" +FCFLAGS_TARGET_FMS = -I../../$(DEPS)/include +LDFLAGS_TARGET_FMS = -L../../$(DEPS)/lib +PATH_TARGET = PATH="${PATH}:../../$(DEPS)/bin" # Define the build targets in terms of the traditional DEBUG/REPRO/etc labels @@ -209,14 +209,15 @@ build/%/MOM6: build/%/Makefile # Use autoconf to construct the Makefile for each target .PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/Makefile) -build/%/Makefile: ../configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) +build/%/Makefile: ../ac/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ - && $(FC_ENV) ../../../configure $(AC_FLAGS) \ + && $(FC_ENV) ../../../ac/configure $(AC_FLAGS) \ || (cat config.log && false) -../configure: ../configure.ac ../Makefile.in ../m4 +# TODO: Replace m4 with *.m4 macros +../ac/configure: ../ac/configure.ac ../ac/Makefile.in ../ac/m4 autoreconf -i $< @@ -236,9 +237,9 @@ $(TARGET_CODEBASE): git clone --recursive $(MOM_TARGET_URL) $@ cd $@ && git checkout $(MOM_TARGET_BRANCH) # Copy modern autoconf files to target? - cp ../configure.ac $(TARGET_CODEBASE)/ - cp ../Makefile.in $(TARGET_CODEBASE)/ - cp -r ../m4 $(TARGET_CODEBASE)/ + cp ../ac/configure.ac $(TARGET_CODEBASE)/ + cp ../ac/Makefile.in $(TARGET_CODEBASE)/ + cp -r ../ac/m4 $(TARGET_CODEBASE)/ # FMS diff --git a/Makefile.in b/ac/Makefile.in similarity index 100% rename from Makefile.in rename to ac/Makefile.in diff --git a/configure.ac b/ac/configure.ac similarity index 75% rename from configure.ac rename to ac/configure.ac index 2da14c1381..73340ba250 100644 --- a/configure.ac +++ b/ac/configure.ac @@ -15,9 +15,26 @@ AC_INIT( [], [https://github.com/NOAA-GFDL/MOM6]) +#--- +# NOTE: For the autoconf-adverse, the configuration files and autoreconf output +# are kept in the `ac` directory. +# +# This breaks the convention where configure.ac resides in the top directory. +# +# As a result, $srcdir initially points to the `ac` directory, rather than the +# top directory of the codebase. +# +# In order to balance this, we up-path (../) srcdir and point AC_CONFIG_SRCDIR +# to srcdir and point AC_CONFIG_SRCDIR to the parent directory. +# +# Someday we may revert this and work from the top-level directory. But for +# now we will compartment autoconf to a subdirectory. +#--- + # Validate srdcir and configure input -AC_CONFIG_SRCDIR([src/core/MOM.F90]) +AC_CONFIG_SRCDIR([../src/core/MOM.F90]) AC_CONFIG_MACRO_DIR([m4]) +srcdir=$srcdir/.. # Default to asymmetric grid @@ -30,7 +47,8 @@ AS_IF([test "$enable_symmetric" = yes], [MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric]) -## TODO: Support a user-defined memory header +# TODO: Rather than point to a pre-configured header file, autoconf could be +# used to configure a header based on a template. #AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) @@ -97,9 +115,9 @@ AS_IF( AX_FC_CHECK_MODULE([fms_mod], [], [ AS_UNSET([ax_fc_cv_mod_fms_mod]) AX_FC_CHECK_MODULE([fms_mod], - [AC_SUBST([FCFLAGS], ["-I${srcdir}/deps/include $FCFLAGS"])], + [AC_SUBST([FCFLAGS], ["-I${srcdir}/ac/deps/include $FCFLAGS"])], [AC_MSG_ERROR([Could not find fms_mod Fortran module.])], - [-I${srcdir}/deps/include]) + [-I${srcdir}/ac/deps/include]) ]) # Test for fms_init to verify FMS library linking @@ -107,11 +125,11 @@ AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [], [ AS_UNSET([ax_fc_cv_lib_FMS_fms_init]) AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [ - AC_SUBST([LDFLAGS], ["-L${srcdir}/deps/lib $LDFLAGS"]) + AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"]) AC_SUBST([LIBS], ["-lFMS $LIBS"]) ], [AC_MSG_ERROR([Could not find FMS library.])], - [-L${srcdir}/deps/lib]) + [-L${srcdir}/ac/deps/lib]) ] ) @@ -119,19 +137,19 @@ AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], # Search for mkmf build tools AC_PATH_PROG([LIST_PATHS], [list_paths]) AS_IF([test -z "$LIST_PATHS"], [ - AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/deps/bin"]) + AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/ac/deps/bin"]) AS_IF([test -z "$LIST_PATHS"], [AC_MSG_ERROR([Could not find list_paths.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/deps/bin"])]) + [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) ] ) AC_PATH_PROG([MKMF], [mkmf]) AS_IF([test -z "$MKMF"], [ - AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/deps/bin"]) + AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/ac/deps/bin"]) AS_IF([test -z "$MKMF"], [AC_MSG_ERROR([Could not find mkmf.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/deps/bin"])]) + [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) ] ) @@ -152,5 +170,5 @@ AC_CONFIG_COMMANDS([Makefile.mkmf], # Prepare output AC_SUBST(CPPFLAGS) -AC_CONFIG_FILES(Makefile) +AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) AC_OUTPUT diff --git a/deps/.gitignore b/ac/deps/.gitignore similarity index 100% rename from deps/.gitignore rename to ac/deps/.gitignore diff --git a/deps/Makefile b/ac/deps/Makefile similarity index 100% rename from deps/Makefile rename to ac/deps/Makefile diff --git a/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in similarity index 100% rename from deps/Makefile.fms.in rename to ac/deps/Makefile.fms.in diff --git a/deps/configure.fms.ac b/ac/deps/configure.fms.ac similarity index 100% rename from deps/configure.fms.ac rename to ac/deps/configure.fms.ac diff --git a/m4/ax_fc_allow_arg_mismatch.m4 b/ac/m4/ax_fc_allow_arg_mismatch.m4 similarity index 100% rename from m4/ax_fc_allow_arg_mismatch.m4 rename to ac/m4/ax_fc_allow_arg_mismatch.m4 diff --git a/m4/ax_fc_allow_invalid_boz.m4 b/ac/m4/ax_fc_allow_invalid_boz.m4 similarity index 100% rename from m4/ax_fc_allow_invalid_boz.m4 rename to ac/m4/ax_fc_allow_invalid_boz.m4 diff --git a/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4 similarity index 100% rename from m4/ax_fc_check_lib.m4 rename to ac/m4/ax_fc_check_lib.m4 diff --git a/m4/ax_fc_check_module.m4 b/ac/m4/ax_fc_check_module.m4 similarity index 100% rename from m4/ax_fc_check_module.m4 rename to ac/m4/ax_fc_check_module.m4 diff --git a/m4/ax_fc_cray_pointer.m4 b/ac/m4/ax_fc_cray_pointer.m4 similarity index 100% rename from m4/ax_fc_cray_pointer.m4 rename to ac/m4/ax_fc_cray_pointer.m4 diff --git a/m4/ax_fc_real8.m4 b/ac/m4/ax_fc_real8.m4 similarity index 100% rename from m4/ax_fc_real8.m4 rename to ac/m4/ax_fc_real8.m4 diff --git a/m4/ax_mpi.m4 b/ac/m4/ax_mpi.m4 similarity index 100% rename from m4/ax_mpi.m4 rename to ac/m4/ax_mpi.m4 From ffeb747ed0d4d0ade97db4873cb3e7644156d0f8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 9 Sep 2020 16:37:59 -0400 Subject: [PATCH 225/256] Autoconf: FMS build adjustment Modified FMS to build libFMS.a in its build directory, rather than to just target the eventual destination of it (../../lib/libFMS.a). This is because other builds (particularly .testing) may prefer a different destination. --- ac/deps/Makefile | 6 ++++-- ac/deps/Makefile.fms.in | 3 +++ ac/deps/configure.fms.ac | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/ac/deps/Makefile b/ac/deps/Makefile index f0a06071b1..6571a4b8db 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -59,11 +59,13 @@ mkmf: # handled more safely, but this is adequate for now. # TODO: track *.mod copy? -lib/libFMS.a: fms/build/Makefile +lib/libFMS.a: fms/build/libFMS.a fms/build/Makefile mkdir -p {lib,include} - cd fms/build && $(MAKE) -j ../../lib/libFMS.a + cp fms/build/libFMS.a lib/libFMS.a cp fms/build/*.mod include +fms/build/libFMS.a: fms/build/Makefile + make -C fms/build libFMS.a # TODO: Include FC, CC, CFLAGS? fms/build/Makefile: FC_ENV=$(FCFLAGS_ENV) diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index 7fda994c8c..694ad8e0b0 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -42,4 +42,7 @@ CPPFLAGS = @CPPFLAGS@ FFLAGS = @FCFLAGS@ LDFLAGS = @LDFLAGS@ +# Gather modulefiles +TMPFILES = $(wildcard *.mod) + include Makefile.mkmf diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index 7b7e6748bf..76bb39bf31 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -113,7 +113,7 @@ AC_CONFIG_COMMANDS([path_names], AC_CONFIG_COMMANDS([mkmf], - [${MKMF} -p ../../lib/libFMS.a -m Makefile.mkmf path_names], + [${MKMF} -p libFMS.a -m Makefile.mkmf path_names], [MKMF=${MKMF}]) From 7ae514ee905940025acac522b9da6c2ce2a2ffc4 Mon Sep 17 00:00:00 2001 From: jkenigson Date: Wed, 9 Sep 2020 17:05:56 -0600 Subject: [PATCH 226/256] Moved variable declarations to correct subroutine! --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d338785406..7931ba2143 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -158,8 +158,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -691,6 +689,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV logical :: use_Stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB I4dt = 0.25 / dt From b67d3c6bcdf5533070cc91d93f099e1cd1db3bec Mon Sep 17 00:00:00 2001 From: Jessica Kenigson Date: Wed, 9 Sep 2020 20:33:44 -0600 Subject: [PATCH 227/256] Fixed a typo in variable name --- .gitmodules | 6 ++++++ pkg/geoKdTree | 1 + pkg/mom6_da_hooks | 1 + src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 4 files changed, 9 insertions(+), 1 deletion(-) create mode 160000 pkg/geoKdTree create mode 160000 pkg/mom6_da_hooks diff --git a/.gitmodules b/.gitmodules index 637f1188ed..fcddebca83 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,9 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git +[submodule "pkg/geoKdTree"] + path = pkg/geoKdTree + url = https://github.com/travissluka/geoKdTree.git +[submodule "pkg/mom6_da_hooks"] + path = pkg/mom6_da_hooks + url = https://github.com/NOAA-GFDL/MOM6_DA_hooks.git diff --git a/pkg/geoKdTree b/pkg/geoKdTree new file mode 160000 index 0000000000..f8ac844ac5 --- /dev/null +++ b/pkg/geoKdTree @@ -0,0 +1 @@ +Subproject commit f8ac844ac558979e43697a6f5e7d9305efea088e diff --git a/pkg/mom6_da_hooks b/pkg/mom6_da_hooks new file mode 160000 index 0000000000..9c930afc5e --- /dev/null +++ b/pkg/mom6_da_hooks @@ -0,0 +1 @@ +Subproject commit 9c930afc5e2c4f86085476f524fc71dec321f68b diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7931ba2143..d4530ebb2d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -778,7 +778,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. - Tsgs2(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) + Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif !$OMP do From 5fb8ea502781cc930d5714dcf08f8c67cf473e55 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 10 Sep 2020 22:59:50 -0400 Subject: [PATCH 228/256] Autoconf: .testing now builds its own FMS .testing no longer relies on the top-level ac/deps to build and hold its FMS repository. It now checks out its own source and builds its own FMS library exclusively for testing. Also fixed a few dependency bugs in the FMS makefile (and probably in .testing as well). Finally, the m4 macros for FMS were copied into deps, rather than sharing with the top-level m4 macros, allowing it to exist more independently. (I will prune the FMS-specific macros from ac/m4 in a future commit.) --- .testing/.gitignore | 1 + .testing/Makefile | 107 ++++++++------- ac/deps/Makefile | 36 +++-- ac/deps/configure.fms.ac | 1 - ac/deps/m4/ax_fc_allow_arg_mismatch.m4 | 58 ++++++++ ac/deps/m4/ax_fc_allow_invalid_boz.m4 | 54 ++++++++ ac/deps/m4/ax_fc_check_lib.m4 | 52 ++++++++ ac/deps/m4/ax_fc_check_module.m4 | 28 ++++ ac/deps/m4/ax_fc_cray_pointer.m4 | 53 ++++++++ ac/deps/m4/ax_fc_real8.m4 | 86 ++++++++++++ ac/deps/m4/ax_mpi.m4 | 176 +++++++++++++++++++++++++ 11 files changed, 588 insertions(+), 64 deletions(-) create mode 100644 ac/deps/m4/ax_fc_allow_arg_mismatch.m4 create mode 100644 ac/deps/m4/ax_fc_allow_invalid_boz.m4 create mode 100644 ac/deps/m4/ax_fc_check_lib.m4 create mode 100644 ac/deps/m4/ax_fc_check_module.m4 create mode 100644 ac/deps/m4/ax_fc_cray_pointer.m4 create mode 100644 ac/deps/m4/ax_fc_real8.m4 create mode 100644 ac/deps/m4/ax_mpi.m4 diff --git a/.testing/.gitignore b/.testing/.gitignore index ec8eae6348..488edabfe8 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -3,3 +3,4 @@ /build/ /work/ /results/ +/deps/ diff --git a/.testing/Makefile b/.testing/Makefile index c91dcc0a97..299bcad730 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -31,7 +31,7 @@ FCFLAGS_COVERAGE ?= #--- # Dependencies -DEPS = ../ac/deps +DEPS = deps # mkmf, list_paths (GFDL build toolchain) LIST_PATHS := $(DEPS)/bin/list_paths @@ -137,60 +137,43 @@ BUILD_TARGETS = MOM6 Makefile path_names # Conditionally build symmetric with coverage support COVERAGE=$(if $(REPORT_COVERAGE),"$(FCFLAGS_COVERAGE)",) -# Explicit FMS link to target build +# .testing dependencies # TODO: We should probably build TARGET with the FMS that it was configured # to use. But for now we use the same FMS over all builds. -FCFLAGS_TARGET_FMS = -I../../$(DEPS)/include -LDFLAGS_TARGET_FMS = -L../../$(DEPS)/lib -PATH_TARGET = PATH="${PATH}:../../$(DEPS)/bin" +FCFLAGS_FMS = -I../../$(DEPS)/include +LDFLAGS_FMS = -L../../$(DEPS)/lib +PATH_FMS = PATH="${PATH}:../../$(DEPS)/bin" # Define the build targets in terms of the traditional DEBUG/REPRO/etc labels -FCFLAGS_SYMMETRIC = -ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT)$(COVERAGE),) - FCFLAGS_SYMMETRIC := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(COVERAGE)" -endif +SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(COVERAGE) $(FCFLAGS_FMS)" +ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" +REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_FMS)" +OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" +TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" -FCFLAGS_TARGET = -FCFLAGS_ASYMMETRIC = -FCFLAGS_OPENMP = -ifneq ($(FCFLAGS_DEBUG)$(FCFLAGS_INIT),) - FCFLAGS_TARGET := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_TARGET_FMS)" - FCFLAGS_ASYMMETRIC := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" - FCFLAGS_OPENMP := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT)" -else - FCFLAGS_TARGET := FCFLAGS="$(FCFLAGS_TARGET_FMS)" -endif - -FCFLAGS_REPRO_RUN = -ifneq ($(FCFLAGS_REPRO),) - FCFLAGS_REPRO_RUN := FCFLAGS="$(FCFLAGS_REPRO)" -endif - -LDFLAGS_SYMMETRIC = -ifneq ($(COVERAGE),) - LDFLAGS_SYMMETRIC := LDFLAGS="$(COVERAGE)" -endif -LDFLAGS_TARGET := LDFLAGS="$(LDFLAGS_TARGET_FMS)" +MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_FMS)" +SYMMETRIC_LDFLAGS := LDFLAGS="$(COVERAGE) $(LDFLAGS_FMS)" # Environment variable configuration -build/symmetric/Makefile: FC_ENV=$(FCFLAGS_SYMMETRIC) $(LDFLAGS_SYMMETRIC) -build/asymmetric/Makefile: FC_ENV=$(FCFLAGS_ASYMMETRIC) -build/repro/Makefile: FC_ENV=$(FCFLAGS_REPRO_RUN) -build/openmp/Makefile: FC_ENV=$(FCFLAGS_OPENMP) -build/target/Makefile: FC_ENV=$(FCFLAGS_TARGET) $(LDFLAGS_TARGET) $(PATH_TARGET) +build/symmetric/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) +build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/repro/Makefile: MOM_ENV=$(PATH_FMS) $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +build/openmp/Makefile: MOM_ENV=$(PATH_FMS) $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags -build/asymmetric/Makefile: AC_FLAGS= -build/openmp/Makefile: AC_FLAGS=--enable-symmetric --enable-openmp -build/target/Makefile: AC_FLAGS=--srcdir=../../$(TARGET_CODEBASE) --enable-symmetric -build/%/Makefile: AC_FLAGS=--enable-symmetric +build/symmetric/Makefile: MOM_ACFLAGS=--enable-symmetric +build/asymmetric/Makefile: MOM_ACFLAGS= +build/repro/Makefile: MOM_ACFLAGS=--enable-symmetric +build/openmp/Makefile: MOM_ACFLAGS=--enable-symmetric --enable-openmp +build/target/Makefile: MOM_ACFLAGS=--srcdir=../../$(TARGET_CODEBASE) --enable-symmetric # Fetch regression target source code -build/target/Makefile: $(TARGET_CODEBASE) +build/target/Makefile: | $(TARGET_CODEBASE) # Define source code dependencies @@ -209,23 +192,22 @@ build/%/MOM6: build/%/Makefile # Use autoconf to construct the Makefile for each target .PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/Makefile) -build/%/Makefile: ../ac/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) +build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ - && $(FC_ENV) ../../../ac/configure $(AC_FLAGS) \ + && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) \ || (cat config.log && false) -# TODO: Replace m4 with *.m4 macros -../ac/configure: ../ac/configure.ac ../ac/Makefile.in ../ac/m4 +../ac/configure: ../ac/configure.ac ../ac/m4 autoreconf -i $< # Fetch the regression target codebase -build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) +build/target/Makefile: $(TARGET_CODEBASE)/configure build/fms/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ - && $(FC_ENV) ../../$(TARGET_CODEBASE)/configure $(AC_FLAGS) \ + && $(MOM_ENV) ../../$(TARGET_CODEBASE)/configure $(MOM_ACFLAGS) \ || (cat config.log && false) @@ -242,17 +224,42 @@ $(TARGET_CODEBASE): cp -r ../ac/m4 $(TARGET_CODEBASE)/ +#--- # FMS -$(DEPS)/lib/libFMS.a: $(DEPS)/Makefile $(FMS_SOURCE) $(MKMF) $(LIST_PATHS) - FCFLAGS_FMS="$(FCFLAGS_DEBUG)" $(MAKE) -C $(DEPS) lib/libFMS.a +# TODO: *.mod dependencies? +$(DEPS)/lib/libFMS.a: $(DEPS)/fms/build/libFMS.a + $(MAKE) -C $(DEPS) lib/libFMS.a + +$(DEPS)/fms/build/libFMS.a: $(DEPS)/fms/build/Makefile + $(MAKE) -C $(DEPS) fms/build/libFMS.a + +$(DEPS)/fms/build/Makefile: $(DEPS)/fms/src/configure $(DEPS)/Makefile.fms.in $(MKMF) $(LIST_PATHS) + PATH_ENV="${PATH}:../../bin" FCFLAGS_ENV="$(FCFLAGS_DEBUG)" $(MAKE) -C $(DEPS) fms/build/Makefile + +$(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in + cp $< $(DEPS) + +# TODO: m4 dependencies? +$(DEPS)/fms/src/configure: ../ac/deps/configure.fms.ac $(DEPS)/Makefile $(FMS_SOURCE) | $(DEPS)/fms/src + cp ../ac/deps/configure.fms.ac $(DEPS) + cp -r ../ac/deps/m4 $(DEPS) + $(MAKE) -C $(DEPS) fms/src/configure + +$(DEPS)/fms/src: $(DEPS)/Makefile + make -C $(DEPS) fms/src # mkmf $(MKMF) $(LIST_PATHS): $(DEPS)/mkmf + $(MAKE) -C $(DEPS) bin/$(@F) $(DEPS)/mkmf: $(DEPS)/Makefile - $(MAKE) -C $(DEPS) bin/$(@F) + $(MAKE) -C $(DEPS) mkmf +# Dependency init +$(DEPS)/Makefile: ../ac/deps/Makefile + mkdir -p $(@D) + cp $< $@ #--- # Python preprocessing @@ -266,7 +273,7 @@ work/local-env: && pip3 install numpy \ && pip3 install netCDF4 -#---- +#--- # Testing .PHONY: test diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 6571a4b8db..91fe343047 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -2,13 +2,20 @@ SHELL = bash .SUFFIXES: # FMS build configuration -# TODO: Include FC? -FCFLAGS_FMS ?= +PATH_ENV ?= +FCFLAGS_ENV ?= # Only set FCFLAGS if an argument is provided. -FCFLAGS_ENV = -ifneq ($(FCFLAGS_FMS),) - FCFLAGS_ENV := FCFLAGS="$(FCFLAGS_FMS)" +FMS_FCFLAGS = +ifneq ($(FCFLAGS_ENV),) + FMS_FCFLAGS := FCFLAGS="$(FCFLAGS_ENV)" +endif + + +# Ditto for path +FMS_PATH = +ifneq ($(PATH_ENV),) + FMS_PATH := PATH="$(PATH_ENV)" endif @@ -64,25 +71,26 @@ lib/libFMS.a: fms/build/libFMS.a fms/build/Makefile cp fms/build/libFMS.a lib/libFMS.a cp fms/build/*.mod include + fms/build/libFMS.a: fms/build/Makefile make -C fms/build libFMS.a + # TODO: Include FC, CC, CFLAGS? -fms/build/Makefile: FC_ENV=$(FCFLAGS_ENV) +fms/build/Makefile: FMS_ENV=$(FMS_PATH) $(FMS_FCFLAGS) -fms/build/Makefile: fms/src/configure bin/mkmf bin/list_paths +fms/build/Makefile: Makefile.fms.in fms/src/configure bin/mkmf bin/list_paths mkdir -p fms/build - cd $(@D) && $(FC_ENV) ../src/configure --srcdir=../src + cp Makefile.fms.in fms/src/Makefile.in + cd $(@D) && $(FMS_ENV) ../src/configure --srcdir=../src # TODO: Track m4 macros? -fms/src/configure: fms/src configure.fms.ac Makefile.fms.in $(FMS_SOURCE) - cp configure.fms.ac $ +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ(2.50) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI From 3ce4172b6ddb16f658b834e535e353d1c5c4d9ab Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 10 Sep 2020 23:33:37 -0800 Subject: [PATCH 229/256] Clean up pass_var for tracer reservoirs. --- src/core/MOM_open_boundary.F90 | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d0f7caa0c2..2320c7d78a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1588,10 +1588,18 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & To_All+Scalar_Pair) if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) - if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) then + if (associated(OBC%tres_x) .and. associated(OBC%tres_y)) then do m=1,OBC%ntr call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) enddo + elseif (associated(OBC%tres_x)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_x(:,:,:,m), G%Domain, position=EAST_FACE) + enddo + elseif (associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) + enddo endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid @@ -4717,8 +4725,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif ! Still painfully inefficient, now in four dimensions. - ! Allocating both for now so that the pass_vector works. - if (any(OBC%tracer_x_reservoirs_used) .or. any(OBC%tracer_y_reservoirs_used)) then + if (any(OBC%tracer_x_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr @@ -4734,8 +4741,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif endif enddo -! endif -! if (any(OBC%tracer_y_reservoirs_used)) then + endif + if (any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr From 304d0c76e00ec4591d20a02e4c40f64148eb297a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 18:02:35 +0000 Subject: [PATCH 230/256] Post tracer concentration when synced Tracer concentrations were being posted at the same time as the transport diagnostics. This leads to some unexpected behavior (e.g. SST and 3D temperature are not consistent) because the concentrations are potentially being posted at an intermediate state. In addition to fixing this problem for all tracers, the subroutine has been renamed to be more descriptive of what kinds of diagnostics might fall into this category. --- src/core/MOM.F90 | 4 ++-- src/tracer/MOM_tracer_registry.F90 | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ad9e235b27..5790dc625e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -100,7 +100,7 @@ module MOM use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init use MOM_tracer_hor_diff, only : tracer_hor_diff_end, tracer_hor_diff_CS use MOM_tracer_registry, only : tracer_registry_type, register_tracer, tracer_registry_init -use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics +use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync use MOM_tracer_registry, only : post_tracer_transport_diagnostics use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end @@ -785,7 +785,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + call post_tracer_diagnostics_at_sync(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 01d15fb887..f1ad26c916 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -29,7 +29,7 @@ module MOM_tracer_registry public register_tracer public MOM_tracer_chksum, MOM_tracer_chkinv -public register_tracer_diagnostics, post_tracer_diagnostics, post_tracer_transport_diagnostics +public register_tracer_diagnostics, post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics public tracer_registry_init, lock_tracer_registry, tracer_registry_end public tracer_name_lookup @@ -630,9 +630,9 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) end subroutine postALE_tracer_diagnostics -!> post_tracer_diagnostics does post_data calls for any diagnostics that are -!! being handled via the tracer registry. -subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) +!> Post tracer diganostics when that should only be posted when MOM's state +!! is self-consistent (also referred to as 'synchronized') subroutine +post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -656,6 +656,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) call diag_copy_storage_to_diag(diag, diag_prev) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) + if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) if (Tr%id_tendency > 0) then work3d(:,:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -681,7 +682,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) endif ; enddo call diag_restore_grids(diag) -end subroutine post_tracer_diagnostics +end subroutine post_tracer_diagnostics_at_sync !> Post the advective and diffusive tendencies subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) @@ -700,7 +701,6 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) - if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) From e93c031f1f2b47170f5fa26410d3076a2ed10a48 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 19:10:29 +0000 Subject: [PATCH 231/256] Neglected subroutine in new declaration Careless me left out 'subroutine' in the declaration of post_tracer_diagnostics_at_sync --- src/tracer/MOM_tracer_registry.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c0281301ff..7ebd7bf917 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -710,7 +710,7 @@ end subroutine postALE_tracer_diagnostics !> Post tracer diganostics when that should only be posted when MOM's state !! is self-consistent (also referred to as 'synchronized') subroutine -post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) +subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry From 503eaa31dc2b26a3a886567b4461e1f100b39ddf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 11 Sep 2020 15:10:41 -0400 Subject: [PATCH 232/256] Update MOM_tracer_registry.F90 Corrected an obvious syntax error in a subroutine declaration. --- src/tracer/MOM_tracer_registry.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c0281301ff..c06846d53b 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -709,8 +709,8 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) end subroutine postALE_tracer_diagnostics !> Post tracer diganostics when that should only be posted when MOM's state -!! is self-consistent (also referred to as 'synchronized') subroutine -post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) +!! is self-consistent (also referred to as 'synchronized') +subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry From 32b47bbe4537204fcecbf347a00962b18b67db67 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 11 Sep 2020 16:14:17 -0400 Subject: [PATCH 233/256] Autoconf: Cray ptr update; macro cleanup The AX_FC_CRAY_POINTER macro was heavily updated to better use the intrinsic Autoconf and M4 macros, as well as to introduce both pass/fail macros and an additional PGI test (which doesn't seem needed but *shrug*). Additional processing is no longer needed when invoking this macro. It now automatically applies the Cray pointer flags to FCFLAGS if invoked, and it now automatically aborts of such macros are not supported, although both of these operations can be overridden if necessary. Several FMS macros unused by MOM6 were also removed from the MOM6 m4 macro folder. --- ac/deps/configure.fms.ac | 5 --- ac/deps/m4/ax_fc_cray_pointer.m4 | 75 ++++++++++++++++--------------- ac/m4/ax_fc_allow_arg_mismatch.m4 | 58 ------------------------ ac/m4/ax_fc_allow_invalid_boz.m4 | 54 ---------------------- ac/m4/ax_fc_cray_pointer.m4 | 53 ---------------------- 5 files changed, 38 insertions(+), 207 deletions(-) delete mode 100644 ac/m4/ax_fc_allow_arg_mismatch.m4 delete mode 100644 ac/m4/ax_fc_allow_invalid_boz.m4 delete mode 100644 ac/m4/ax_fc_cray_pointer.m4 diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index aaa1e86764..79f59d95c2 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -52,11 +52,6 @@ AC_DEFINE([use_netCDF]) # Enable Cray pointers AX_FC_CRAY_POINTER -AS_IF([test "$enable_cray_ptr" != no], - [FCFLAGS="$FCFLAGS $CRAY_POINTER_FCFLAGS"], - [AC_MSG_ERROR(["$FC cannot support Cray pointers"])] -) - # Force 8-byte reals AX_FC_REAL8 diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 index a00b10edf6..0b52325baa 100644 --- a/ac/deps/m4/ax_fc_cray_pointer.m4 +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -1,4 +1,4 @@ -dnl Test if Cray pointers are supported. +dnl AX_FC_CRAY_POINTER([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE]) dnl dnl This macro tests if any flags are required to enable Cray pointers. dnl @@ -6,48 +6,49 @@ dnl Cray pointers provided a means for more direct access to memory. Since dnl such references can potentially violate certain requirements of the dnl language standard, they are typically considered a vendor extension. dnl -dnl Most compilers provide these in some form. As far as I can tell, only GNU -dnl explicitly requires a flag. Known tests are shown below, but additional -dnl feedback is required to fill this out. +dnl Most compilers provide these in some form. A partial list of supported +dnl flags are shown below, but additional feedback is required for other +dnl compilers. dnl -dnl Flags +dnl The known flags are: dnl GCC -fcray-pointer dnl Intel Fortran none -dnl PGI Fortran none +dnl PGI Fortran -Mcray=pointer dnl Cray Fortran none dnl -AC_DEFUN([AX_FC_CRAY_POINTER], - [CRAY_POINTER_FCFLAGS= - AC_CACHE_CHECK([for $FC option to support Cray pointers], - [ac_cv_prog_fc_cray_ptr], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - integer aptr(2) - pointer (iptr, aptr) - ])], - [ac_cv_prog_fc_cray_ptr='none needed'], - [ac_cv_prog_fc_cray_ptr='unsupported' - for ac_option in -fcray-pointer; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([], [ - integer aptr(2) - pointer (iptr, aptr) - ])], - [ac_cv_prog_fc_cray_ptr=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_cray_ptr" != unsupported; then - break - fi - done]) +AC_DEFUN([AX_FC_CRAY_POINTER], [ + AC_LANG_ASSERT([Fortran]) + AC_MSG_CHECKING([for $FC option to support Cray pointers]) + AC_CACHE_VAL([ac_cv_fc_cray_ptr], [ + ac_cv_fc_cray_ptr='unknown' + ac_save_FCFLAGS=$FCFLAGS + for ac_option in none -fcray-pointer -Mcray=pointer; do + test "$ac_option" != none && FCFLAGS="$ac_save_FCFLAGS $ac_option" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + integer aptr(2) + pointer (iptr, aptr) + ])], + [ac_cv_fc_cray_ptr=$ac_option], + ) + FCFLAGS=$ac_save_FCFLAGS + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [break]) + done ]) - case $ac_cv_prog_fc_cray_ptr in #( - "none needed" | unsupported) - ;; #( + case "$ac_cv_fc_cray_ptr" in + none) + AC_MSG_RESULT([none needed]) ;; + unknown) + AC_MSG_RESULT([unsupported]) ;; *) - CRAY_POINTER_FCFLAGS=$ac_cv_prog_fc_cray_ptr ;; + AC_MSG_RESULT([$ac_cv_fc_cray_ptr]) ;; esac - AC_SUBST(CRAY_POINTER_FCFLAGS) + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [ + m4_default([$1], [ + AS_IF([test "$ac_cv_fc_cray_ptr" != none], + [FCFLAGS="$FCFLAGS $ac_cv_fc_cray_ptr"] + ) + ])], + [m4_default([$2], [AC_MSG_ERROR(["$FC does not support Cray pointers"])])] + ) ]) diff --git a/ac/m4/ax_fc_allow_arg_mismatch.m4 b/ac/m4/ax_fc_allow_arg_mismatch.m4 deleted file mode 100644 index cffa302c66..0000000000 --- a/ac/m4/ax_fc_allow_arg_mismatch.m4 +++ /dev/null @@ -1,58 +0,0 @@ -dnl Test if mismatched function arguments are permitted. -dnl -dnl This macro tests if a flag is required to enable mismatched functions in -dnl a single translation unit (aka file). -dnl -dnl If a compiler encounters two undefined programs with different input -dnl argument types, then it may regard this as a mismatch which requires action -dnl from the user. A common example is a procedure which may be called with -dnl a variable of either an integer or a real type. -dnl -dnl This can happen, for example, if one is relying on an interface to resolve -dnl such differences, but one is also relying on a legacy header interface via -dnl `#include` rather than an explicit module which includes the complete -dnl interface specification. -dnl -dnl No modern project is expected to see these issues, but this is helpful for -dnl older projects which used legacy headers. -dnl -dnl Flags: -dnl GNU: -fallow-argument-mismatch -dnl -AC_DEFUN([AX_FC_ALLOW_ARG_MISMATCH], - [ALLOW_ARG_MISMATCH_FCFLAGS= - AC_CACHE_CHECK( - [for $FC option to support mismatched procedure arguments], - [ac_cv_prog_fc_arg_mismatch], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - call f(1) - call f(1.0) - ])], - [ac_cv_prog_fc_arg_mismatch='none needed'], - [ac_cv_prog_fc_arg_mismatch='unsupported' - for ac_option in -fallow-argument-mismatch; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - call f(1) - call f(1.0) - ])], - [ac_cv_prog_fc_arg_mismatch=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_arg_mismatch" != unsupported; then - break - fi - done]) - ] - ) - case $ac_cv_prog_fc_arg_mismatch in #( - "none needed" | unsupported) - ;; #( - *) - ALLOW_ARG_MISMATCH_FCFLAGS=$ac_cv_prog_fc_arg_mismatch ;; - esac - AC_SUBST(ALLOW_ARG_MISMATCH_FCFLAGS) -]) diff --git a/ac/m4/ax_fc_allow_invalid_boz.m4 b/ac/m4/ax_fc_allow_invalid_boz.m4 deleted file mode 100644 index 5d4521b5fb..0000000000 --- a/ac/m4/ax_fc_allow_invalid_boz.m4 +++ /dev/null @@ -1,54 +0,0 @@ -dnl Test if BOZ literal assignment is supported. -dnl -dnl This macro tests if a flag is required to enable BOZ literal assignments -dnl for variables. -dnl -dnl BOZ literals (e.g. Z'FFFF') are typeless, and formally cannot be assigned -dnl to typed variables. Nonetheless, few compilers forbid such operations, -dnl despite the potential pitfalls around interpreting such values. -dnl -dnl As of version 10.1, gfortran now forbids such assignments and requires a -dnl flag to convert the raised errors into warnings. -dnl -dnl While the best solution is to replace such assignments with proper -dnl conversion functions, this test is useful to accommodate older projects. -dnl -dnl Flags: -dnl GNU: -fallow-invalid-boz -AC_DEFUN([AX_FC_ALLOW_INVALID_BOZ], - [ALLOW_INVALID_BOZ_FCFLAGS= - AC_CACHE_CHECK( - [for $FC option to support invalid BOZ assignment], - [ac_cv_prog_fc_invalid_boz], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - integer n - n = z'ff' - ])], - [ac_cv_prog_fc_invalid_boz='none needed'], - [ac_cv_prog_fc_invalid_boz='unsupported' - for ac_option in -fallow-invalid-boz; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([], [ - integer n - n = z'ff' - ])], - [ac_cv_prog_fc_invalid_boz=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_invalid_boz" != unsupported; then - break - fi - done]) - ] - ) - case $ac_cv_prog_fc_invalid_boz in #( - "none needed" | unsupported) - ;; #( - *) - ALLOW_INVALID_BOZ_FCFLAGS=$ac_cv_prog_fc_invalid_boz ;; - esac - AC_SUBST(ALLOW_INVALID_BOZ_FCFLAGS)] -) diff --git a/ac/m4/ax_fc_cray_pointer.m4 b/ac/m4/ax_fc_cray_pointer.m4 deleted file mode 100644 index a00b10edf6..0000000000 --- a/ac/m4/ax_fc_cray_pointer.m4 +++ /dev/null @@ -1,53 +0,0 @@ -dnl Test if Cray pointers are supported. -dnl -dnl This macro tests if any flags are required to enable Cray pointers. -dnl -dnl Cray pointers provided a means for more direct access to memory. Since -dnl such references can potentially violate certain requirements of the -dnl language standard, they are typically considered a vendor extension. -dnl -dnl Most compilers provide these in some form. As far as I can tell, only GNU -dnl explicitly requires a flag. Known tests are shown below, but additional -dnl feedback is required to fill this out. -dnl -dnl Flags -dnl GCC -fcray-pointer -dnl Intel Fortran none -dnl PGI Fortran none -dnl Cray Fortran none -dnl -AC_DEFUN([AX_FC_CRAY_POINTER], - [CRAY_POINTER_FCFLAGS= - AC_CACHE_CHECK([for $FC option to support Cray pointers], - [ac_cv_prog_fc_cray_ptr], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - integer aptr(2) - pointer (iptr, aptr) - ])], - [ac_cv_prog_fc_cray_ptr='none needed'], - [ac_cv_prog_fc_cray_ptr='unsupported' - for ac_option in -fcray-pointer; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([], [ - integer aptr(2) - pointer (iptr, aptr) - ])], - [ac_cv_prog_fc_cray_ptr=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_cray_ptr" != unsupported; then - break - fi - done]) - ]) - case $ac_cv_prog_fc_cray_ptr in #( - "none needed" | unsupported) - ;; #( - *) - CRAY_POINTER_FCFLAGS=$ac_cv_prog_fc_cray_ptr ;; - esac - AC_SUBST(CRAY_POINTER_FCFLAGS) -]) From e45f73f4e163ddf04e9b1451f37613095fec82f2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 23:59:15 +0000 Subject: [PATCH 234/256] Diagnostic for post-transport tracer concentration Adds a tracer diagnostic for the intermediate state of tracer concentrations right after horizontal transport (advection and diffusion) has occurred. For cases where DIABATIC_FIRST = False, this will definitely not be identical to the tracer concentration diagnostic that is posted when the MOM6 state is 'synchronized' (e.g. all forcing terms within a MOM6 timestep have been calculated and applied). --- src/tracer/MOM_tracer_registry.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c06846d53b..cb8f1716fe 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -120,7 +120,7 @@ module MOM_tracer_registry integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. !>@{ Diagnostic IDs - integer :: id_tr = -1 + integer :: id_tr = -1, id_tr_post_horzn = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 @@ -408,6 +408,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & cmor_standard_name=cmor_long_std(cmor_longname)) endif + Tr%id_tr_post_horzn = register_diag_field("ocean_model", & + trim(name)//"_post_horzn", diag%axesTL, Time, & + trim(longname)//" after horizontal transport (advection/diffusion) "//& + "has occurred", trim(units)) if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & @@ -779,6 +783,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) + if (Tr%id_tr_post_horzn> 0) call post_data(Tr%id_tr_post_horzn, Tr%t, diag) if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) From de0c88dd5c38fb1f3594ce3ada7c379c12c7afd8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 15:53:19 -0400 Subject: [PATCH 235/256] Testing: Warn on new diagnostic in regression This patch attempts to detect if a new diagnostic has been added, which was previously interpreted as a regression. Previously, any diff in chksum_diag between a PR and dev/gfdl was interpreted as a regression. This included new diagnostics, which do not actually change any existing answers. This patch only raises an error (blocking the merge) if there are detected changes in dev/gfdl's chksum_diag. If the diff only reports new lines in chksum_diag from the PR, then it reports in the log as a WARN and reports as a PASS to the CI (currently Travis). This patch also fixes a minor typo in the .restart test ($$* should have been $*). Several Make variables using shell-style brackets {} were also replaced with Make brackets (). --- .testing/Makefile | 49 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6f3553a694..f6e0a31b97 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -251,11 +251,13 @@ run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) # Color highlights for test results RED=\033[0;31m +YELLOW=\033[0;33m GREEN=\033[0;32m RESET=\033[0m DONE=${GREEN}DONE${RESET} PASS=${GREEN}PASS${RESET} +WARN=${YELLOW}WARN${RESET} FAIL=${RED}FAIL${RESET} # Comparison rules @@ -267,18 +269,18 @@ define CMP_RULE @cmp $$^ || !( \ mkdir -p results/$$*; \ (diff $$^ | tee results/$$*/ocean.stats.$(1).diff | head) ; \ - echo -e "${FAIL}: Solutions $$*.$(1) have changed." \ + echo -e "$(FAIL): Solutions $$*.$(1) have changed." \ ) - @echo -e "${PASS}: Solutions $$*.$(1) agree." + @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 "$(FAIL): Diagnostics $$*.$(1).diag have changed." \ ) - @echo -e "${PASS}: Diagnostics $$*.$(1).diag agree." + @echo -e "$(PASS): Diagnostics $$*.$(1).diag agree." endef $(eval $(call CMP_RULE,grid,symmetric asymmetric)) @@ -288,7 +290,7 @@ $(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)) +#$(eval $(call CMP_RULE,regression,symmetric target)) # Custom comparison rules @@ -298,13 +300,34 @@ $(eval $(call CMP_RULE,regression,symmetric target)) @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}: Solutions $*.restart have changed." \ + (diff $^ | tee results/$*/chksum_diag.restart.diff | head) ; \ + echo -e "$(FAIL): Solutions $*.restart have changed." \ ) - @echo -e "${PASS}: Solutions $*.restart agree." + @echo -e "$(PASS): Solutions $*.restart agree." # TODO: chksum_diag parsing of restart files +# stats rule is unchanged, but we cannot use CMP_RULE to generate it. +%.regression: $(foreach b,symmetric target,work/%/$(b)/ocean.stats) + @cmp $^ || !( \ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/ocean.stats.regression.diff | head) ; \ + echo -e "$(FAIL): Solutions $*.regression have changed." \ + ) + @echo -e "$(PASS): Solutions $*.regression agree." + +# Regression testing only checks for changes in existing diagnostics +%.regression.diag: $(foreach b,symmetric target,work/%/$(b)/chksum_diag) + @! diff $^ | grep "^[<>]" | grep "^>" \ + || ! (\ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/chksum_diag.regression.diff | head) ; \ + echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ + ) + diff $^ || echo -e "$(WARN): New diagnostics in $<" + @echo -e "$(PASS): Diagnostics $*.regression.diag agree." + + #--- # Test run output files @@ -337,9 +360,9 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ rm ocean.stats chksum_diag ; \ - echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + echo -e "$(FAIL): $$*.$(1) failed at runtime." \ ) - @echo -e "${DONE}: $$*.$(1); no runtime errors." + @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ @@ -395,7 +418,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 || !( \ 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." \ + echo -e "$(FAIL): $*.restart failed at runtime." \ ) # Setup the next inputs cd $(@D) && rm -rf INPUT && mv RESTART INPUT @@ -406,7 +429,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 || !( \ 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." \ + echo -e "$(FAIL): $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics @@ -434,7 +457,7 @@ test.summary: fi; \ false ; \ else \ - echo -e "${PASS}: All tests passed!"; \ + echo -e "$(PASS): All tests passed!"; \ fi From 6a8a699616c9e3d1535d62b108bfc3a2ad378721 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 17:05:18 -0400 Subject: [PATCH 236/256] Autoconf: Travis fix; Cray ptr macro update Resolved some bad string parsing issues of the Travis environment variables. Thanks to Inspector Adcroft for discovering this error. Further cleanup of the Cray pointer test macro, should now be very close to conformant Autoconf M4 format. --- .travis.yml | 10 +++++----- ac/deps/m4/ax_fc_cray_pointer.m4 | 31 ++++++++++++++----------------- 2 files changed, 19 insertions(+), 22 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3fd729f8d1..8987c6e3ff 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,11 +20,11 @@ addons: # Environment variables env: global: - - TIMEFORMAT="Time: %lR (user: %lU, sys: %lS)" - - FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" - - FCFLAGS_REPRO="-g -O2 -fbacktrace" - - FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" - - FCFLAGS_COVERAGE="--coverage" + - TIMEFORMAT: "\"Time: %lR (user: %lU, sys: %lS)\"" + - FCFLAGS_DEBUG: "\"-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds\"" + - FCFLAGS_REPRO: "\"-g -O2 -fbacktrace\"" + - FCFLAGS_INIT: "\"-finit-real=snan -finit-integer=2147483647 -finit-derived\"" + - FCFLAGS_COVERAGE: "\"--coverage\"" jobs: include: diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 index 0b52325baa..a9f5d9bbe3 100644 --- a/ac/deps/m4/ax_fc_cray_pointer.m4 +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -19,34 +19,31 @@ dnl AC_DEFUN([AX_FC_CRAY_POINTER], [ AC_LANG_ASSERT([Fortran]) AC_MSG_CHECKING([for $FC option to support Cray pointers]) - AC_CACHE_VAL([ac_cv_fc_cray_ptr], [ - ac_cv_fc_cray_ptr='unknown' + AC_CACHE_VAL([ac_cv_prog_fc_cray_ptr], [ + ac_cv_prog_fc_cray_ptr='unknown' ac_save_FCFLAGS=$FCFLAGS for ac_option in none -fcray-pointer -Mcray=pointer; do test "$ac_option" != none && FCFLAGS="$ac_save_FCFLAGS $ac_option" AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([], [ - integer aptr(2) - pointer (iptr, aptr) + integer aptr(2) + pointer (iptr, aptr) ])], - [ac_cv_fc_cray_ptr=$ac_option], + [ac_cv_prog_fc_cray_ptr=$ac_option], ) FCFLAGS=$ac_save_FCFLAGS - AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [break]) + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [break]) done ]) - case "$ac_cv_fc_cray_ptr" in - none) - AC_MSG_RESULT([none needed]) ;; - unknown) - AC_MSG_RESULT([unsupported]) ;; - *) - AC_MSG_RESULT([$ac_cv_fc_cray_ptr]) ;; - esac - AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [ + AS_CASE([ac_cv_prog_fc_cray_ptr], + [none], [AC_MSG_RESULT([none_needed])], + [unknown], [AC_MSG_RESULT([unsupported])], + [AC_MSG_RESULT([$ac_cv_prog_fc_cray_ptr])] + ) + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [ m4_default([$1], [ - AS_IF([test "$ac_cv_fc_cray_ptr" != none], - [FCFLAGS="$FCFLAGS $ac_cv_fc_cray_ptr"] + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != none], + [FCFLAGS="$FCFLAGS $ac_cv_prog_fc_cray_ptr"] ) ])], [m4_default([$2], [AC_MSG_ERROR(["$FC does not support Cray pointers"])])] From 2ed83644b0c7a77eb9f698db3b9213125f15035b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 17:31:17 -0400 Subject: [PATCH 237/256] Testing: Fixing bug in target Makefile --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 299bcad730..d438c9ef9e 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -204,7 +204,7 @@ build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) # Fetch the regression target codebase -build/target/Makefile: $(TARGET_CODEBASE)/configure build/fms/libFMS.a $(MKMF) $(LIST_PATHS) +build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/fms/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ && $(MOM_ENV) ../../$(TARGET_CODEBASE)/configure $(MOM_ACFLAGS) \ From ce6843bde131d60f8d92fe706cc82524d7557a4e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 17:41:47 -0400 Subject: [PATCH 238/256] Fixed FMS lib typo in target --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index d438c9ef9e..af758163a2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -204,7 +204,7 @@ build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) # Fetch the regression target codebase -build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/fms/libFMS.a $(MKMF) $(LIST_PATHS) +build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ && $(MOM_ENV) ../../$(TARGET_CODEBASE)/configure $(MOM_ACFLAGS) \ From 4296d6dd555aba57d6289ab0e93ea0435734ebba Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 19:02:41 -0400 Subject: [PATCH 239/256] Autoconf: Fixed several target build errors --- .testing/Makefile | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index af758163a2..da6cef9f7b 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -169,7 +169,7 @@ build/symmetric/Makefile: MOM_ACFLAGS=--enable-symmetric build/asymmetric/Makefile: MOM_ACFLAGS= build/repro/Makefile: MOM_ACFLAGS=--enable-symmetric build/openmp/Makefile: MOM_ACFLAGS=--enable-symmetric --enable-openmp -build/target/Makefile: MOM_ACFLAGS=--srcdir=../../$(TARGET_CODEBASE) --enable-symmetric +build/target/Makefile: MOM_ACFLAGS=--enable-symmetric # Fetch regression target source code @@ -204,24 +204,23 @@ build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) # Fetch the regression target codebase -build/target/Makefile: $(TARGET_CODEBASE)/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) +build/target/Makefile: $(TARGET_CODEBASE)/ac/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) cd $(@D) \ - && $(MOM_ENV) ../../$(TARGET_CODEBASE)/configure $(MOM_ACFLAGS) \ + && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ || (cat config.log && false) -$(TARGET_CODEBASE)/configure: $(TARGET_CODEBASE) - autoreconf -i $< +$(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) + autoreconf -i $ Date: Tue, 15 Sep 2020 16:14:53 -0400 Subject: [PATCH 240/256] Testing: Minor dependency bugfix in Makefile --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index da6cef9f7b..327a7d457e 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -236,7 +236,7 @@ $(DEPS)/fms/build/libFMS.a: $(DEPS)/fms/build/Makefile $(DEPS)/fms/build/Makefile: $(DEPS)/fms/src/configure $(DEPS)/Makefile.fms.in $(MKMF) $(LIST_PATHS) PATH_ENV="${PATH}:../../bin" FCFLAGS_ENV="$(FCFLAGS_DEBUG)" $(MAKE) -C $(DEPS) fms/build/Makefile -$(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in +$(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in $(DEPS)/Makefile cp $< $(DEPS) # TODO: m4 dependencies? From 275b99308feb8417cb0fe27cfa0158db58b7c9c0 Mon Sep 17 00:00:00 2001 From: x Date: Wed, 16 Sep 2020 12:49:48 -0400 Subject: [PATCH 241/256] Autoconf: macOS support; Makefile fixes This patch adds additional support for building FMS in deps on macOS machines, specifically related to affinity. Much of this can be phased out when we upgrade our target FMS from 2019.01.03 to a newer version. Additional dependency errors in .testing/Makefile have also been fixed related to building of the virtual Python environment. --- .testing/Makefile | 12 ++++++------ ac/deps/configure.fms.ac | 42 ++++++++++++++++++++++++++++++++++++++-- 2 files changed, 46 insertions(+), 8 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 327a7d457e..3991e2d7fb 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -25,7 +25,7 @@ FCFLAGS_COVERAGE ?= # - These flags should be configured outside of the Makefile, either with # config.mk or as environment variables. # -# - FMS cannot be build with the same aggressive initialization flags as MOM6, +# - FMS cannot be built with the same aggressive initialization flags as MOM6, # so FCFLAGS_INIT is used to provide additional MOM6 configuration. @@ -125,7 +125,7 @@ endif # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -371,11 +371,11 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # $(5): Environment variables # $(6): Number of MPI ranks define STAT_RULE -work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 +work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 $(VENV_PATH) @echo "Running test $$*.$(1)..." if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) - cp -rL $$*/* $$(@D) + cp -RL $$*/* $$(@D) if [ -f $$(@D)/Makefile ]; then \ $$(VENV_ACTIVATE) \ && cd $$(@D) \ @@ -425,10 +425,10 @@ $(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) # Restart tests require significant preprocessing, and are handled separately. -work/%/restart/ocean.stats: build/symmetric/MOM6 +work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) rm -rf $(@D) mkdir -p $(@D) - cp -rL $*/* $(@D) + cp -RL $*/* $(@D) if [ -f $(@D)/Makefile ]; then \ $(VENV_ACTIVATE) \ && cd work/$*/restart \ diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index 79f59d95c2..1d66194c81 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -13,8 +13,44 @@ AC_PROG_CC AX_MPI CC=$MPICC -# FMS: Check if Linux gettid is avaiable -AC_CHECK_FUNCS([gettid]) +# FMS configuration + +# Linux and OSX have a gettid system call, but it is not implemented in older +# glibc implementations. When unavailable, a native syscall is used. +# +# On Linux, this is defined in unistd.h as __NR_gettid, and FMS is hard-coded +# to use this value. In OS X, this is defined in sys/syscall.h as SYS_gettid, +# so we override this macro if __NR_gettid is unavailable. +AC_CHECK_FUNCS([gettid], [], [ + AC_MSG_CHECKING([if __NR_gettid must be redefined]) + AC_CACHE_VAL([ac_cv_cc_nr_gettid], [ + ac_cv_cc_nr_gettid='unknown' + for nr_gettid in __NR_gettid SYS_gettid; do + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([ +#include +#include + ], [syscall($nr_gettid)] + )], [ac_cv_cc_nr_gettid=$nr_gettid] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [break]) + done + ]) + AS_CASE([ac_cv_cc_nr_gettid], + [__NR_gettid], [AC_MSG_RESULT([none needed])], + [AC_MSG_RESULT([$ac_cv_cc_nr_gettid])] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [ + AS_IF([test "$ac_cv_cc_nr_gettid" != __NR_gettid], + [AC_DEFINE_UNQUOTED([__NR_gettid], [$ac_cv_cc_nr_gettid])] + )], [ + AC_MSG_ERROR(["Could not find the gettid syscall ID"]) + ]) +]) + + +# FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. +AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) # Standard Fortran configuration @@ -53,6 +89,7 @@ AC_DEFINE([use_netCDF]) # Enable Cray pointers AX_FC_CRAY_POINTER + # Force 8-byte reals AX_FC_REAL8 AS_IF( @@ -75,6 +112,7 @@ AC_FC_LINE_LENGTH([unlimited]) AX_FC_ALLOW_INVALID_BOZ FCFLAGS="$FCFLAGS $ALLOW_INVALID_BOZ_FCFLAGS" + # Allow argument mismatch (for functions lacking interfaces) AX_FC_ALLOW_ARG_MISMATCH FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS" From ad84de0928c57eb85a03bf687694807a1bff4f14 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 16 Sep 2020 17:02:04 -0400 Subject: [PATCH 242/256] Correct submodule setup - Commit b67d3c6bcdf5533070cc91d93f099e1cd1db3bec added back two submodules that still exist on the NCAR branch but no longer are used in the GFDL branch and soon will be expunged on the main branch too. This removes the submodules as was done in NOAA_GFDL/MOM6#1139. --- .gitmodules | 6 ------ pkg/geoKdTree | 1 - pkg/mom6_da_hooks | 1 - 3 files changed, 8 deletions(-) delete mode 160000 pkg/geoKdTree delete mode 160000 pkg/mom6_da_hooks diff --git a/.gitmodules b/.gitmodules index fcddebca83..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git -[submodule "pkg/mom6_da_hooks"] - path = pkg/mom6_da_hooks - url = https://github.com/NOAA-GFDL/MOM6_DA_hooks.git diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index f8ac844ac5..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f8ac844ac558979e43697a6f5e7d9305efea088e diff --git a/pkg/mom6_da_hooks b/pkg/mom6_da_hooks deleted file mode 160000 index 9c930afc5e..0000000000 --- a/pkg/mom6_da_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9c930afc5e2c4f86085476f524fc71dec321f68b From ac27e44a57488de732af8e3ea8f060666452c7e3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 16 Sep 2020 17:28:47 -0400 Subject: [PATCH 243/256] Updates units and adds OpenMP directives - Following suggestions from @Hallberg-NOAA for PR #1193, I've copied the more completely-documented declaration lines from PressureForce_FV_Bouss() to thickness_diffuse_full(). - Similarly to the other module made a change of an intermediate variable to its reciprocal. - Corrected missing OpenMP directives for some local variables. --- .../lateral/MOM_thickness_diffuse.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d4530ebb2d..3de7b0121b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -675,7 +675,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: dTdi2, dTdj2 ! pot. temp. differences, squared. + real :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: hl(5) ! Copy of local stencil of H [H ~> m] + real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics @@ -689,8 +693,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV logical :: use_Stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB I4dt = 0.25 / dt @@ -732,7 +734,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & !$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & !$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & -!$OMP private(dTdi2,dTdj2) +!$OMP private(hl,r_sm_H,Tl,mn_T,mn_T2) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 @@ -765,17 +767,16 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff - mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) ! Mean of T Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. ! Variance of T mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) From 039a75dba6f84459ba73234c846ed936c8b3d4eb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 16 Sep 2020 22:25:27 -0400 Subject: [PATCH 244/256] Autoconf: Default updates autoconf now defaults to using symmetric grids, rather than asymmetric grids. The DEBUG/REPRO build comparison is now disabled on default, since many platforms do not produce equivalent results. If this situation improves, then it can be re-enabled. --- .testing/Makefile | 23 ++++++++++++----------- .travis.yml | 1 + ac/Makefile.in | 18 +++++++----------- ac/configure.ac | 14 +++++++------- 4 files changed, 27 insertions(+), 29 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index bcce1c6290..6ea2d18370 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -7,10 +7,6 @@ SHELL = bash # Set the MPI launcher here MPIRUN ?= mpirun -# Many compilers (Intel, GCC on ARM64) do not yet produce identical results -# across DEBUG and REPRO builds. For these platforms, set to false -DO_REPRO_TESTS ?= true - # Default target compiler flags # NOTE: FMS will be built using FCFLAGS_DEBUG FCFLAGS_DEBUG ?= -g -O0 @@ -20,7 +16,7 @@ FCFLAGS_COVERAGE ?= # Additional notes: # # - The default values are simple, minimalist flags, supported by nearly all -# compilers and meant to represent GFDL's canonical DEBUG and REPRO builds. +# compilers which are comparable to GFDL's canonical DEBUG and REPRO builds. # # - These flags should be configured outside of the Makefile, either with # config.mk or as environment variables. @@ -28,6 +24,11 @@ FCFLAGS_COVERAGE ?= # - FMS cannot be built with the same aggressive initialization flags as MOM6, # so FCFLAGS_INIT is used to provide additional MOM6 configuration. +# Set to `true` to require identical results from DEBUG and REPRO builds +DO_REPRO_TESTS ?= + +# Many compilers (Intel, GCC on ARM64) do not yet produce identical results +# across DEBUG and REPRO builds (as defined below), so we disable on default. #--- # Dependencies @@ -165,11 +166,11 @@ build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags -build/symmetric/Makefile: MOM_ACFLAGS=--enable-symmetric -build/asymmetric/Makefile: MOM_ACFLAGS= -build/repro/Makefile: MOM_ACFLAGS=--enable-symmetric -build/openmp/Makefile: MOM_ACFLAGS=--enable-symmetric --enable-openmp -build/target/Makefile: MOM_ACFLAGS=--enable-symmetric +build/symmetric/Makefile: MOM_ACFLAGS= +build/asymmetric/Makefile: MOM_ACFLAGS=--enable-asymmetric +build/repro/Makefile: MOM_ACFLAGS= +build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp +build/target/Makefile: MOM_ACFLAGS= # Fetch regression target source code @@ -378,7 +379,7 @@ $(foreach d,$(DIMS),$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) (diff $^ | tee results/$*/chksum_diag.regression.diff | head) ; \ echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ ) - diff $^ || echo -e "$(WARN): New diagnostics in $<" + @diff $^ || echo -e "$(WARN): New diagnostics in $<" @echo -e "$(PASS): Diagnostics $*.regression.diag agree." diff --git a/.travis.yml b/.travis.yml index 8987c6e3ff..22c497f916 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,6 +25,7 @@ env: - FCFLAGS_REPRO: "\"-g -O2 -fbacktrace\"" - FCFLAGS_INIT: "\"-finit-real=snan -finit-integer=2147483647 -finit-derived\"" - FCFLAGS_COVERAGE: "\"--coverage\"" + - DO_REPRO_TESTS: true jobs: include: diff --git a/ac/Makefile.in b/ac/Makefile.in index a1b1b9118a..81d9f9a8e4 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -1,18 +1,14 @@ # Makefile template for MOM6 # -# Previously this would have been generated by mkmf using a template file. +# Compiler flags are configured by autoconf's configure script. # -# The proposed autoconf build inverts this approach by constructing the -# information previously stored in the mkmf template, such as compiler names -# and flags, and importing the un-templated mkmf output for its rules and -# dependencies. +# Source code dependencies are configured by mkmf and list_paths, specified in +# the `Makefile.mkmf` file. # -# While this approach does not eliminate our dependency on mkmf, it does -# promises to eliminate our reliance on platform-specific templates, and -# instead allows us to provide a configure script for determining our compilers -# and flags. As a last resort, we provide hooks to override such settings. - -# NOTE: mkmf conventions are close, but not identical, to autoconf. +# mkmf conventions are close, but not identical, to autoconf. We attempt to +# map the autoconf variables to the mkmf variables. +# +# The following variables are used by Makefiles generated by mkmf. # # CC: C compiler # CXX: C++ compiler diff --git a/ac/configure.ac b/ac/configure.ac index 73340ba250..ee6b76dacb 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -28,7 +28,7 @@ AC_INIT( # to srcdir and point AC_CONFIG_SRCDIR to the parent directory. # # Someday we may revert this and work from the top-level directory. But for -# now we will compartment autoconf to a subdirectory. +# now we will isolate autoconf to a subdirectory. #--- # Validate srdcir and configure input @@ -37,14 +37,14 @@ AC_CONFIG_MACRO_DIR([m4]) srcdir=$srcdir/.. -# Default to asymmetric grid +# Default to symmetric grid # NOTE: --enable is more properly used to add a feature, rather than to select # a compile-time mode, so this is not exactly being used as intended. -MEM_LAYOUT=${srcdir}/config_src/dynamic -AC_ARG_ENABLE([symmetric], - AS_HELP_STRING([--enable-symmetric], [Enable symmetric grid])) -AS_IF([test "$enable_symmetric" = yes], - [MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric]) +MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric +AC_ARG_ENABLE([asymmetric], + AS_HELP_STRING([--enable-asymmetric], [Use the asymmetric grid])) +AS_IF([test "$enable_asymmetric" = yes], + [MEM_LAYOUT=${srcdir}/config_src/dynamic]) # TODO: Rather than point to a pre-configured header file, autoconf could be From c518096609a57d6921fb981e7f0c96d20cdd2e12 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 12:58:13 -0400 Subject: [PATCH 245/256] Testing: Updated the README --- .testing/README.md | 212 +++++++++++++++++++++++++++------------------ 1 file changed, 129 insertions(+), 83 deletions(-) diff --git a/.testing/README.md b/.testing/README.md index abad08ada8..5e1a088725 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -2,30 +2,43 @@ This directory contains the Makefile and test configurations used to evaluate submissions to the MOM6 codebase. The tests are designed to run either locally -or in a Travis-CI. +or in a CI environment such as Travis. ## Overview This section gives a very brief overview of the test suite and how to use it. -To build and run the model tests +To build and run the model tests: ``` make make test ``` +Users may wish to use `make -j` in place of `make` to enable parallel builds. -Regression testing is disabled on default. To include regression tests: +For new users, the default configuration should be suitable for most platforms. +If not, then the following options may need to be configured. + +`MPIRUN` (*default:* `mpirun`) + + Name of the MPI launcher. Often this is `mpirun` or `mpiexec` but may all + need to run through a scheduler, e.g. `srun` if using Slurm. + +`DO_REGRESSION_TESTS` (*default: none*) + + Set to `true` to compare output with `dev/gfdl`. + +`DO_REPRO_TESTS` (*default: none*) + + Set to `true` to compare DEBUG and REPRO builds, which typically correspond + to unoptimized and optimized builds. See TODO for more information. + +These settings can either be specified at the command line, as shown below. ``` make DO_REGRESSION_TESTS=true make test DO_REGRESSION_TESTS=true ``` - -On platforms other than Gaea, a MKMF build template may be required. To -specify the path to the template: -``` -make MKMF_TEMPLATE=/path/to/template.mk -``` +or saved to `config.mk`. To run individual classes of tests, use the subclass name: ``` @@ -33,11 +46,11 @@ make test.grids make test.layouts make DO_REGRESSION_TESTS=true test.regressions ``` - To test an individual test configuration (TC): ``` make tc0.grid ``` +See "Tests" and "Test Configurations" for the complete list of tests. The rest of the document describes the test suite in more detail, including names and descriptions of the test classes and configurations. @@ -45,21 +58,86 @@ names and descriptions of the test classes and configurations. ## Testing overview -The test suite consists of many comparisons of model output for different model -configurations when subjected to relevant numerical and mathematical -transformations, such as grid layout or dimensional rescaling, for which the -model output should be invariant. If the model state is unchanged after each -transformation, then the test is reported as passing. Any discrepancy in the -model state causes the test to fail. +The test suite checks for numerical consistency of the model output of +different model configurations when subjected to relevant numerical and +mathematical transformations, such as grid layout or dimensional rescaling. If +the model state is unchanged after each transformation, then the test is +reported as passing. Any discrepancy in the model state causes the test to +fail. Model state is currently defined by the `ocean.stats` output file, which reports the total energy (per unit mass) at machine precision alongside similar global metrics, such as mass or mean sea level, at lower precision. -Checksums for every available diagnostic are also compared and the Makefile -will report any differences, but such differences are not yet considered a fail -condition. +Diagnostics are based on the MOM checksum function, which includes the mean, +minimum, and maximum values as well as a bitcount in the physical domain (i.e. +excluding halos), as saved to the `chksum_diag` output file. + +Additional diagnostics do not report as a fail, and are not tracked by any CIs, +but the test will report a warning to the user. + + +## Build configuration + +The test suite defines a DEBUG and a REPRO build, which resemble targets used +at GFDL. The DEBUG build is intended for detecting potential errors and +troubleshooting, while the REPRO build has typically been optimized for +production runs. + +Ideally, the DEBUG and REPRO runs will produce identical results, although this +is often not the case for many compilers and platforms. The `DO_REPRO_TEST` +flag is used to test DEBUG/REPRO equivalency. + +The following options are provided to configure your compiler flags. + +`FCFLAGS_DEBUG` (*default:* `-g -O0`) + + Specify the flags used in the DEBUG build. These are the flags used for all + tests excepting the REPRO builds. They are also used to build the FMS + library. + + These should be used to enable settings favorable to debugging, such as no + optimizations, backtraces, range checking, and warning. + + For more aggressive flags which cannot be used with FMS, see `FCFLAGS_INIT`. + +`FCFLAGS_REPRO:` (*default:* `-g -O2`) + + Specify the optimized reproducible run, typically used in production runs. + + Ideally, this should consist of optimization flags which improve peformance + but do not change model output. In practice, this is difficult to achieve. + +`FCFLAGS_INIT` (*default: none*) + + This flag was historically used to specify variable initialization, such as + nonzero integers or floating point values, and is still generally used for + this purpose. + + As implemented, it is used for all MOM6 builds. It is not used for FMS + builds, so can also act as a debugging flag independent of FMS. + +`FCFLAGS_COVERAGE` (*default: none*) + + This flag is used to define a build which supports some sort of code + coverage, often one which is handled by the CI. + For many compilers, this is `--coverage`, and is applied to both the + compiler (`FCFLAGS`) and linker (`LDFLAGS`). + +Example values used by GFDL and Travis for the GFortran compiler are shown +below. +``` +FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" +FCFLAGS_REPRO="-g -O2 -fbacktrace" +FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" +FCFLAGS_COVERAGE="--coverage" +``` + +Note that the default values for these flags are very minimal, in order to +ensure compatibility over the largest possible range of compilers. + +Like all configuration variables, these can be specified in a `config.mk` file. ## Building the executables @@ -73,64 +151,51 @@ configuration uses the symmetric grid in the debug-compile mode, with optimizations disabled and stronger quality controls. The following executables will be created: -- `build/symmetric/MOM6`: Symmetric grid configuration (extended grids along - western and/or southern boundaries). This is the default configuration. +- `build/symmetric/MOM6`: Symmetric grid configuration (i.e. extended grids + along western and/or southern boundaries for selected fields). This is the + default configuration. - `build/asymmetric/MOM6`: Non-symmetric grid (equal-sized grids) - `build/repro/MOM6`: Optimized reproducible mode -- (optional) `build/target/MOM6`: A reference build for regression testing +- `build/target/MOM6`: A reference build for regression testing -The `target` build is only created when the `DO_REGRESSION_TESTS` flag is set -to `true`: -``` -make DO_REGRESSION_TESTS=true -``` -When set, the build will check out a second copy of the repository from a -specified URL and branch given by `MOM_TARGET_URL` and `MOM_TARGET_BRANCH`, -respectively. The code is checked out into the `TARGET_CODEBASE` directory. +- `build/openmp/MOM6`: OpenMP-enabled build -The current default settings are +The `target` and `repro` builds are only created when their respective tests +are set to `true`. + +### Regression testing + +When regression tests are enabled, the Makefile will check out a second copy of +the repository from a specified URL and branch given by `MOM_TARGET_URL` and +`MOM_TARGET_BRANCH`, respectively. The code is checked out into the +`TARGET_CODEBASE` directory. + +The default settings, with resolved values as comments, are shown below. ``` MOM_TARGET_SLUG = NOAA-GFDL/MOM6 MOM_TARGET_URL = https://github.com/$(MOM_TARGET_SLUG) -# = https://github.com/NOAA-GFDL/MOM6 + #= https://github.com/NOAA-GFDL/MOM6 MOM_TARGET_LOCAL_BRANCH = dev/gfdl MOM_TARGET_BRANCH = origin/$(MOM_TARGET_LOCAL_BRANCH) -# = origin/dev/gfdl + #= origin/dev/gfdl TARGET_CODEBASE = $(BUILD)/target_codebase ``` These default values can be configured to target a particular development branch. - -#### MKMF template - -The MKMF build toolchain requires a template file when building the model. The -default template, `ncrc-gnu.mk`, is part of the MKMF repository, but has been -specifically configured for use on NOAA's Gaea computer, and other institutes -will require their own template files. - -The template can be specified as a Make flag. -``` -make MKMF_TEMPLATE=/path/to/template.mk -``` -The `linux-ubuntu-xenial-gnu.mk` template is provided in the `.testing` -directory, and is intended for Travis-CI builds, but may also be a good -reference point for other Linux distributions. - -In the future, this step may be replaced with a more generalized build system, -such as CMake or automake. +Currently the target can only be specifed by branch name, rather than hash. ## Tests -Using `test` will run through the test suite. +Using `test` will run through the full test suite. ``` make test ``` -This will run through the following tests: +The tests are gathered into the following groups. - `test.regressions`: Regression tests relative to a code state (when enabled) - `test.grids`: Symmetric vs nonsymmetric grids @@ -140,13 +205,7 @@ This will run through the following tests: - `test.nans`: NaN initialization of allocated arrays - `test.dims`: Dimensional scaling (length, time, thickness, depth) -To enable the regression tests, use `DO_REGRESSION_TEST=true`. -``` -make test DO_REGRESSION_TESTS=true -``` - -Each test can also be run individually. For example, the following command -will only run the grid tests. +Each group of tests can also be run individually. ``` make test.grids ``` @@ -157,15 +216,15 @@ fail if the answers differ from this build. ## Test configurations -The following test configurations (TCs) are supported: +The following model test configurations (TCs) are supported: -- tc0: Unit testing of various model components, based on `unit_tests` -- tc1: A low-resolution version of the `benchmark` configuration - - tc1.a: Use the un-split mode with Runge-Kutta 3 time integration - - tc1.b: Use the un-split mode with Runge-Kutta 2 time integration -- tc2: An ALE configuration based on tc1 with tides - - tc2.a: Use sigma, PPM_H4 and no tides -- tc3: An open-boundary condition (OBC) test based on `circle_obcs` +- `tc0`: Unit testing of various model components, based on `unit_tests` +- `tc1`: A low-resolution version of the `benchmark` configuration + - `tc1.a`: Use the un-split mode with Runge-Kutta 3 time integration + - `tc1.b`: Use the un-split mode with Runge-Kutta 2 time integration +- `tc2`: An ALE configuration based on tc1 with tides + - `tc2.a`: Use sigma, PPM_H4 and no tides +- `tc3`: An open-boundary condition (OBC) test based on `circle_obcs` ## Code coverage @@ -194,6 +253,8 @@ suite is triggered and the code changes are tested. When the tests are run on Travis, the following variables are re-defined: +- `DO_REPRO_TESTS` is set to `true` for all tests. + - `DO_REGRESSION_TESTS` is set to `true` for a PR submission, and is unset for code pushes. @@ -209,18 +270,3 @@ When the tests are run on Travis, the following variables are re-defined: a PR, this is the name of the branch which is receiving the PR. - `REPORT_COVERAGE` is set to `true`. - -## Running under slurm - -By default the executables are invoked using `mpirun`. Under slurm you might need to -use `srun` (such as on GFDL's gaea HPC): -``` -make MPIRUN=srun test -``` - -For convenience you can provide some macro in the file `config.mk`. For example, on -gaea, to be able to run `make test -s -j` you will find putting the line -``` -MPIRUN = srun -mblock --exclusive -``` -in `config.mk` very useful. From b01af9d2e4ff6575a0c416c3cc338de6f66ba0c4 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 15:53:41 -0400 Subject: [PATCH 246/256] Autoconf: Documentation, make ac-clean fix Added several documentation READMEs to using the autoconf build. Also added some changes to the Makefile template so that `make ac-clean` wiped out the autoconf output (configure, aclocal.m4, autom4te.cache). --- README.md | 16 ++++- ac/Makefile.in | 6 +- ac/README.md | 177 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 195 insertions(+), 4 deletions(-) create mode 100644 ac/README.md diff --git a/README.md b/README.md index 3e4ff016e3..842186ceb1 100644 --- a/README.md +++ b/README.md @@ -6,12 +6,14 @@ This is the MOM6 source code. + # Where to find information Start at the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki) which has installation instructions. [Source code documentation](http://mom6.readthedocs.io/) is hosted on read the docs. + # What files are what The top level directory structure groups source code and input files as follow: @@ -23,7 +25,19 @@ The top level directory structure groups source code and input files as follow: | ```src/``` | Contains the source code for MOM6 that is always compiled. | | ```config_src/``` | Contains optional source code depending on mode and configuration such as dynamic-memory versus static, ocean-only versus coupled. | | ```pkg/``` | Contains third party (non-MOM6 or FMS) code that is compiled into MOM6. | -| ```docs/``` | Workspace for generated documentation. | +| ```docs/``` | Workspace for generated documentation. See [docs/README.md](docs/README.md) | +| ```.testing/``` | COntains the verification test suite. See [.testing/README.md](testing/README.md) | +| ```ac/``` | Contains the autoconf build configuration files. See [ac/README.md](ac/README.md) | + + +# Quick start guide + +To quickly get started and build an ocean-only MOM6 executable, see the +[autoconf README](ac/README.md). + +For setting up an experiment, or building an executable for coupled modeling, +consult the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + # Disclaimer diff --git a/ac/Makefile.in b/ac/Makefile.in index 81d9f9a8e4..ce8173e6f1 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -73,6 +73,6 @@ distclean: clean # Don't be surprised if the name changes or if it disappears someday. .PHONY: ac-clean ac-clean: distclean - rm -f aclocal.m4 - rm -rf autom4te.cache - rm -f configure + rm -f @srcdir@/ac/aclocal.m4 + rm -rf @srcdir@/ac/autom4te.cache + rm -f @srcdir@/ac/configure diff --git a/ac/README.md b/ac/README.md new file mode 100644 index 0000000000..5cc14b448b --- /dev/null +++ b/ac/README.md @@ -0,0 +1,177 @@ +# Autoconf Build Configuration + +This directory contains the configuration files required to build MOM6 using +autoconf. + +Note that a top-level `./configure` is not contained in the repository, and the +instruction below will generate this script in the `ac` directory. + + +# Requirements + +The following tools and libraries must be installed on your system. + +* autoconf +* Fortran compiler (e.g. gfortran) +* MPI (e.g. Open MPI, MPICH) +* netCDF, with Fortran support + +On some platforms, such as macOS, the autoconf package may also require an +installation of automake. + +Some packages such as netCDF may require an additional packages for Fortran +support. + + +# Quick start guide + +The following instructions will allow a new user to quickly create a MOM6 +executable for ocean-only simulations. + +A separate Makefile in `ac/deps/` is provided to gather and build any GFDL +dependencies. +``` +cd ac/deps +make -j +``` +This will fetch the `mkmf` tool and build the `libFMS` library. + +To build MOM6, first generate the autconf `configure` script. +``` +cd ac +autoreconf +``` +Then select your build directory, e.g. `./build`, run the configure script, and +build the model. +``` +mkdir -p build +cd build +../ac/configure +make -j +``` +This will create the MOM6 executable in the build directory. + +This executable is only useable for ocean-only simulations, and still requires +the necessary experiment configuration files, such as `input.nml` and +`MOM_input`. For more information, consult the +[MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + + +# Build rules + +The Makefile produced by autoconf provides the following rules. + +``make`` + + Build the MOM6 executable. + +``make clean`` + + Delete the executable and any object and module files, but preserve the + autoconf output. + +``make distclean`` + + Delete all of the files above, as well as any files generated by + `./configure`. Note that this will delete the Makefile containing this rule. + +``make ac-clean`` + + Delete all of the files above, including `./configure` and any other files + created by `autoconf`. As with `make distclean`, this will also delete the + Makefile containing this rule. + + +# Build configuration settings + +Autoconf will resolve most model depenencies, and includes the standard set +of configuration options, such as `FC` or `FCFLAGS`. The MOM6-specific +`configure` script settings are described below. + +`--enable-asymmetric` + + The MOM6 executable is configured to use symmetric grids by default. + + Use the flag above to compile using uniform asymmetric grids. + + Symmetric grids are defined such that the fields for every C-grid cell are + fully specified by their local values. In particular, quantities such as + velocities or vorticity will be defined along the boundaries of the domain. + + Use of symmetric grids simplifies calculations, but also results in + nonuniform domain sizes for different fields, and slightly greater storage + since the additional values can be considered redundant. + +`--enable-openmp` + + Use this flag to enable OpenMP in the build. + +`--disable-real-8` + + While MOM6 does not explicitly use double-precision reals, most of the + algorithms are designed and tested under this assumption. + + This flag may be used to disable these flags, causing the compiler to use the + default size (usually single-precision), although there is no guarantee that + the model will be useable. + +For the complete list of settings, run `./configure --help`. + + +# GFDL Dependencies + +This section briefly describes the management of GFDL dependencies `mkmf` and +FMS. + +The `configure` script will first check if the compiler flags (`FCFLAGS`, +`LDFLAGS`, etc.) can find `mkmf` and the FMS library. If unavailable, then it +will search in the local `ac/deps` library. If still unavailable, because it +has not yet been built, then the build will abort. + +Running `make -C ac/deps` will ensure that the libraries are available. But if +the user wishes to target an external FMS library, then they should add the +appropriate `FCFLAGS` and `LDFLAGS` to find the library. + +Similar options are provided for `mkmf` with respect to `PATH`, although it +is usually not necessary to use an external `mkmf` script. + +Some configuration options are provided by the `ac/deps` Makefile: + +`PATH_ENV` + + This variable will override the value of `PATH` when building the dependencies. + +`FCFLAGS_ENV` + + Used to override the default autoconf flags, `-g -O2`. This is useful if, + for example, one wants to build with `-O0` to speed up the build time. + +`MKMF_URL` (*default:* https://github.com/NOAA-GFDL/mkmf.git) +`MKMF_COMMIT`(*default:* `master`) +`FMS_URL` (*default:* https://github.com/NOAA-GFDL/FMS.git) +`FMS_COMMIT` (*default:* `2019.01.03`) + + These are used to specify where to check out the source code for each + respective project. + + +# Known issues / Future development + +## MPI configuration + +There are minor issues with the MPI configuration macro, where it may locate an +MPI launcher based on a compiler which does not match the corresponding +compiler, `FC`, which will tend to default to GFortran. + +This is usually not an issue, but can cause confusion when the `FCFLAGS` were +configured for the launcher but do not work with `FC`, whose value is only used +in the initial `configure` testing. + +To resolve this, ensure that `FC` and `FCFLAGS` are specified for the same +compiler. + +## Coupled builds + +The autoconf build is currently only capable of building ocean-only +executables, and cannot yet be build as a standalone library. This is planned +to be addressed in a future release. From 255ee70da0d20a4ab127d6fc515ff5176d4691ac Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 16:41:29 -0400 Subject: [PATCH 247/256] Autoconf/Testing README proofreading --- .testing/README.md | 52 +++++++++++++----------- ac/README.md | 99 +++++++++++++++++++++++++--------------------- 2 files changed, 81 insertions(+), 70 deletions(-) diff --git a/.testing/README.md b/.testing/README.md index 5e1a088725..adc56e56cd 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -11,11 +11,9 @@ This section gives a very brief overview of the test suite and how to use it. To build and run the model tests: ``` -make -make test +make -j +make -j test ``` -Users may wish to use `make -j` in place of `make` to enable parallel builds. - For new users, the default configuration should be suitable for most platforms. If not, then the following options may need to be configured. @@ -33,12 +31,12 @@ If not, then the following options may need to be configured. Set to `true` to compare DEBUG and REPRO builds, which typically correspond to unoptimized and optimized builds. See TODO for more information. -These settings can either be specified at the command line, as shown below. +These settings can either be specified at the command line, as shown below ``` make DO_REGRESSION_TESTS=true make test DO_REGRESSION_TESTS=true ``` -or saved to `config.mk`. +or saved in a configuration file, `config.mk`. To run individual classes of tests, use the subclass name: ``` @@ -58,7 +56,7 @@ names and descriptions of the test classes and configurations. ## Testing overview -The test suite checks for numerical consistency of the model output of +The test suite checks for numerical consistency of the model output across different model configurations when subjected to relevant numerical and mathematical transformations, such as grid layout or dimensional rescaling. If the model state is unchanged after each transformation, then the test is @@ -67,14 +65,11 @@ fail. Model state is currently defined by the `ocean.stats` output file, which reports the total energy (per unit mass) at machine precision alongside similar -global metrics, such as mass or mean sea level, at lower precision. +global metrics at lower precision, such as mass or mean sea level. Diagnostics are based on the MOM checksum function, which includes the mean, -minimum, and maximum values as well as a bitcount in the physical domain (i.e. -excluding halos), as saved to the `chksum_diag` output file. - -Additional diagnostics do not report as a fail, and are not tracked by any CIs, -but the test will report a warning to the user. +minimum, and maximum values, alongside a bitcount checksum, in the physical +domain, which are saved in the `chksum_diag` output file. ## Build configuration @@ -97,16 +92,18 @@ The following options are provided to configure your compiler flags. library. These should be used to enable settings favorable to debugging, such as no - optimizations, backtraces, range checking, and warning. + optimizations, backtraces, range checking, and warnings. - For more aggressive flags which cannot be used with FMS, see `FCFLAGS_INIT`. + For more aggressive debugging flags which cannot be used with FMS, see + `FCFLAGS_INIT`. `FCFLAGS_REPRO:` (*default:* `-g -O2`) Specify the optimized reproducible run, typically used in production runs. Ideally, this should consist of optimization flags which improve peformance - but do not change model output. In practice, this is difficult to achieve. + but do not change model output. In practice, this is difficult to achieve, + and should only used in certain environments. `FCFLAGS_INIT` (*default: none*) @@ -122,7 +119,7 @@ The following options are provided to configure your compiler flags. This flag is used to define a build which supports some sort of code coverage, often one which is handled by the CI. - For many compilers, this is `--coverage`, and is applied to both the + For many compilers, this is set to `--coverage`, and is applied to both the compiler (`FCFLAGS`) and linker (`LDFLAGS`). Example values used by GFDL and Travis for the GFortran compiler are shown @@ -139,6 +136,7 @@ ensure compatibility over the largest possible range of compilers. Like all configuration variables, these can be specified in a `config.mk` file. + ## Building the executables Run `make` to build the test executables. @@ -149,7 +147,7 @@ This will fetch the MKMF build toolchain, fetch and compile the FMS framework library, and compile the executables used in the test suite. The default configuration uses the symmetric grid in the debug-compile mode, with optimizations disabled and stronger quality controls. The following -executables will be created: +executables will be created. - `build/symmetric/MOM6`: Symmetric grid configuration (i.e. extended grids along western and/or southern boundaries for selected fields). This is the @@ -166,6 +164,7 @@ executables will be created: The `target` and `repro` builds are only created when their respective tests are set to `true`. + ### Regression testing When regression tests are enabled, the Makefile will check out a second copy of @@ -188,6 +187,9 @@ branch. Currently the target can only be specifed by branch name, rather than hash. +New diagnostics do not report as a fail, and are not tracked by any CIs, but +the test will report a warning to the user. + ## Tests @@ -205,7 +207,8 @@ The tests are gathered into the following groups. - `test.nans`: NaN initialization of allocated arrays - `test.dims`: Dimensional scaling (length, time, thickness, depth) -Each group of tests can also be run individually. +Each group of tests can also be run individually, such as in the following +example. ``` make test.grids ``` @@ -216,7 +219,8 @@ fail if the answers differ from this build. ## Test configurations -The following model test configurations (TCs) are supported: +The following model test configurations (TCs) are supported, and are based on +configurations in the MOM6-examples repository. - `tc0`: Unit testing of various model components, based on `unit_tests` - `tc1`: A low-resolution version of the `benchmark` configuration @@ -229,13 +233,13 @@ The following model test configurations (TCs) are supported: ## Code coverage -Code coverage reports the lines of code which have been tested, and can -explicitly demonstrate when a particular operation is untested. +Code coverage reports the lines of code which have been tested, and can be used +to determine if a particular section is untested. Coverage is measured using `gcov` and is reported for TCs using the `symmetric` executable. -Coverage reporting is optionally sent to the `codecov.io` site. +Coverage reporting is optionally uploaded to the `codecov.io` site. ``` https://codecov.io/gh/NOAA-GFDL/MOM6 ``` @@ -243,7 +247,7 @@ This is disabled on default, but can be enabled by the `REPORT_COVERAGE` flag. ``` make test REPORT_COVERAGE=true ``` -Note that any uploads will require a valid token generated by CodeCov. +Note that any uploads will require a valid CodeCov token. ## Running on Travis diff --git a/ac/README.md b/ac/README.md index 5cc14b448b..d02f793a86 100644 --- a/ac/README.md +++ b/ac/README.md @@ -1,7 +1,7 @@ # Autoconf Build Configuration This directory contains the configuration files required to build MOM6 using -autoconf. +Autoconf. Note that a top-level `./configure` is not contained in the repository, and the instruction below will generate this script in the `ac` directory. @@ -11,13 +11,13 @@ instruction below will generate this script in the `ac` directory. The following tools and libraries must be installed on your system. -* autoconf -* Fortran compiler (e.g. gfortran) +* Autoconf +* Fortran compiler (e.g. GFortran) * MPI (e.g. Open MPI, MPICH) * netCDF, with Fortran support -On some platforms, such as macOS, the autoconf package may also require an -installation of automake. +On some platforms, such as macOS, the Autoconf package may also require an +installation of Automake. Some packages such as netCDF may require an additional packages for Fortran support. @@ -28,38 +28,41 @@ support. The following instructions will allow a new user to quickly create a MOM6 executable for ocean-only simulations. +Each set of instructions is meant to be run from the root directory of the +repository. + A separate Makefile in `ac/deps/` is provided to gather and build any GFDL dependencies. ``` -cd ac/deps -make -j +$ cd ac/deps +$ make -j ``` -This will fetch the `mkmf` tool and build the `libFMS` library. +This will fetch the `mkmf` tool and build the FMS library. -To build MOM6, first generate the autconf `configure` script. +To build MOM6, first generate the Autoconf `configure` script. ``` -cd ac -autoreconf +$ cd ac +$ autoreconf ``` Then select your build directory, e.g. `./build`, run the configure script, and build the model. ``` -mkdir -p build -cd build -../ac/configure -make -j +$ mkdir -p build +$ cd build +$ ../ac/configure +$ make -j ``` This will create the MOM6 executable in the build directory. -This executable is only useable for ocean-only simulations, and still requires -the necessary experiment configuration files, such as `input.nml` and -`MOM_input`. For more information, consult the +This executable is only useable for ocean-only simulations, and cannot be used +for coupled modeling. It also requires the necessary experiment configuration +files, such as `input.nml` and `MOM_input`. For more information, consult the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). # Build rules -The Makefile produced by autoconf provides the following rules. +The Makefile produced by Autoconf provides the following rules. ``make`` @@ -68,7 +71,7 @@ The Makefile produced by autoconf provides the following rules. ``make clean`` Delete the executable and any object and module files, but preserve the - autoconf output. + Autoconf output. ``make distclean`` @@ -78,27 +81,27 @@ The Makefile produced by autoconf provides the following rules. ``make ac-clean`` Delete all of the files above, including `./configure` and any other files - created by `autoconf`. As with `make distclean`, this will also delete the + created by `autoreconf`. As with `make distclean`, this will also delete the Makefile containing this rule. # Build configuration settings -Autoconf will resolve most model depenencies, and includes the standard set -of configuration options, such as `FC` or `FCFLAGS`. The MOM6-specific -`configure` script settings are described below. +Autoconf will resolve most model dependencies, and includes the standard set of +configuration options, such as `FC` or `FCFLAGS`. The `configure` settings +specific to MOM6 are described below. `--enable-asymmetric` The MOM6 executable is configured to use symmetric grids by default. - Use the flag above to compile using uniform asymmetric grids. + Use the flag above to compile using uniform (asymmetric) grids. Symmetric grids are defined such that the fields for every C-grid cell are fully specified by their local values. In particular, quantities such as - velocities or vorticity will be defined along the boundaries of the domain. + velocities or vorticity are defined along the boundaries of the domain. - Use of symmetric grids simplifies calculations, but also results in + Use of symmetric grids simplifies many calculations, but also results in nonuniform domain sizes for different fields, and slightly greater storage since the additional values can be considered redundant. @@ -108,12 +111,13 @@ of configuration options, such as `FC` or `FCFLAGS`. The MOM6-specific `--disable-real-8` - While MOM6 does not explicitly use double-precision reals, most of the - algorithms are designed and tested under this assumption. + While MOM6 does not explicitly use double precision reals, most of the + algorithms are designed and tested under this assumption, and the default + configuration is to enforce 8-byte reals. - This flag may be used to disable these flags, causing the compiler to use the - default size (usually single-precision), although there is no guarantee that - the model will be useable. + This flag may be used to relax this requirement, causing the compiler to use + the default size (usually single precision reals), although there is no + guarantee that the model will be usable. For the complete list of settings, run `./configure --help`. @@ -123,10 +127,10 @@ For the complete list of settings, run `./configure --help`. This section briefly describes the management of GFDL dependencies `mkmf` and FMS. -The `configure` script will first check if the compiler flags (`FCFLAGS`, -`LDFLAGS`, etc.) can find `mkmf` and the FMS library. If unavailable, then it -will search in the local `ac/deps` library. If still unavailable, because it -has not yet been built, then the build will abort. +The `configure` script will first check if the compiler and its configured +flags (`FCFLAGS`, `LDFLAGS`, etc.) can find `mkmf` and the FMS library. If +unavailable, then it will search in the local `ac/deps` library. If still +unavailable, then the build will abort. Running `make -C ac/deps` will ensure that the libraries are available. But if the user wishes to target an external FMS library, then they should add the @@ -143,7 +147,7 @@ Some configuration options are provided by the `ac/deps` Makefile: `FCFLAGS_ENV` - Used to override the default autoconf flags, `-g -O2`. This is useful if, + Used to override the default Autoconf flags, `-g -O2`. This is useful if, for example, one wants to build with `-O0` to speed up the build time. `MKMF_URL` (*default:* https://github.com/NOAA-GFDL/mkmf.git) @@ -154,24 +158,27 @@ Some configuration options are provided by the `ac/deps` Makefile: These are used to specify where to check out the source code for each respective project. +Additional hooks for FMS builds do not yet exist, but can be added if +necessary. + # Known issues / Future development ## MPI configuration -There are minor issues with the MPI configuration macro, where it may locate an -MPI launcher based on a compiler which does not match the corresponding -compiler, `FC`, which will tend to default to GFortran. +There are minor issues with the MPI configuration macro, where it may use an +MPI build wrapper (e.g. `mpifort`) whose underlying compiler does not match +the `FC` compiler, which will often be auto-configured to `gfortran`. -This is usually not an issue, but can cause confusion when the `FCFLAGS` were -configured for the launcher but do not work with `FC`, whose value is only used -in the initial `configure` testing. +This is usually not an issue, but can cause confusion if `FCFLAGS` is +configured for the MPI wrapper but is incompatible with the `FC` compiler. To resolve this, ensure that `FC` and `FCFLAGS` are specified for the same compiler. + ## Coupled builds -The autoconf build is currently only capable of building ocean-only -executables, and cannot yet be build as a standalone library. This is planned -to be addressed in a future release. +The Autoconf build is currently only capable of building ocean-only +executables, and cannot yet be build as part of a coupled more, nor as a +standalone library. This is planned to be addressed in a future release. From 3f176cca0d831f748cd69a4b3721df53038853d1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 17 Sep 2020 17:18:31 -0400 Subject: [PATCH 248/256] Corrected minor typo --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 842186ceb1..17cf0310db 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ The top level directory structure groups source code and input files as follow: | ```config_src/``` | Contains optional source code depending on mode and configuration such as dynamic-memory versus static, ocean-only versus coupled. | | ```pkg/``` | Contains third party (non-MOM6 or FMS) code that is compiled into MOM6. | | ```docs/``` | Workspace for generated documentation. See [docs/README.md](docs/README.md) | -| ```.testing/``` | COntains the verification test suite. See [.testing/README.md](testing/README.md) | +| ```.testing/``` | Contains the verification test suite. See [.testing/README.md](testing/README.md) | | ```ac/``` | Contains the autoconf build configuration files. See [ac/README.md](ac/README.md) | From 500a960fee973c95c7b3d862d5ee8faaf666229a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 17 Sep 2020 17:20:32 -0400 Subject: [PATCH 249/256] Fixed typo replacing "more" with "model" Pointed out by @raphaeldussin --- ac/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ac/README.md b/ac/README.md index d02f793a86..a708979572 100644 --- a/ac/README.md +++ b/ac/README.md @@ -180,5 +180,5 @@ compiler. ## Coupled builds The Autoconf build is currently only capable of building ocean-only -executables, and cannot yet be build as part of a coupled more, nor as a +executables, and cannot yet be build as part of a coupled model, nor as a standalone library. This is planned to be addressed in a future release. From f0201a45a0f02bc8050129b3e7b580b87350f429 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 17:50:21 -0400 Subject: [PATCH 250/256] Update README.md Typo fix --- ac/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ac/README.md b/ac/README.md index a708979572..12cfbf2b00 100644 --- a/ac/README.md +++ b/ac/README.md @@ -180,5 +180,5 @@ compiler. ## Coupled builds The Autoconf build is currently only capable of building ocean-only -executables, and cannot yet be build as part of a coupled model, nor as a +executables, and cannot yet be built as part of a coupled model, nor as a standalone library. This is planned to be addressed in a future release. From 4c13aead44f522c9d8d7e541a5a0227c1982e17c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 20:12:45 -0400 Subject: [PATCH 251/256] Update README.md Fix typo in README link --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 17cf0310db..dfbfafc7d0 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ The top level directory structure groups source code and input files as follow: | ```config_src/``` | Contains optional source code depending on mode and configuration such as dynamic-memory versus static, ocean-only versus coupled. | | ```pkg/``` | Contains third party (non-MOM6 or FMS) code that is compiled into MOM6. | | ```docs/``` | Workspace for generated documentation. See [docs/README.md](docs/README.md) | -| ```.testing/``` | Contains the verification test suite. See [.testing/README.md](testing/README.md) | +| ```.testing/``` | Contains the verification test suite. See [.testing/README.md](.testing/README.md) | | ```ac/``` | Contains the autoconf build configuration files. See [ac/README.md](ac/README.md) | From 5be482a83fd375f6ceb0612ebeaddb41aae60cb0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Sep 2020 20:17:37 -0400 Subject: [PATCH 252/256] Update README.md Markdown formatting fixes. --- ac/README.md | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/ac/README.md b/ac/README.md index 12cfbf2b00..d5a5310ab8 100644 --- a/ac/README.md +++ b/ac/README.md @@ -151,12 +151,15 @@ Some configuration options are provided by the `ac/deps` Makefile: for example, one wants to build with `-O0` to speed up the build time. `MKMF_URL` (*default:* https://github.com/NOAA-GFDL/mkmf.git) + `MKMF_COMMIT`(*default:* `master`) + `FMS_URL` (*default:* https://github.com/NOAA-GFDL/FMS.git) + `FMS_COMMIT` (*default:* `2019.01.03`) - These are used to specify where to check out the source code for each - respective project. + These are used to specify where to check out the source code for each + respective project. Additional hooks for FMS builds do not yet exist, but can be added if necessary. @@ -180,5 +183,5 @@ compiler. ## Coupled builds The Autoconf build is currently only capable of building ocean-only -executables, and cannot yet be built as part of a coupled model, nor as a +executables, and cannot yet be used as part of a coupled model, nor as a standalone library. This is planned to be addressed in a future release. From 7bea824ea56be8fd2b0a17adf4fa1c4e66ea1dfe Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 22 Sep 2020 11:40:12 -0400 Subject: [PATCH 253/256] Testing: Remove quotes in COVERAGE The COVERAGE variable was incorrectly quoted, and was causing incorrect quotes in the compile flag arguments. This patch removes the redundant quotes. --- .testing/Makefile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6ea2d18370..4b3dfdefb8 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -136,7 +136,7 @@ BUILD_TARGETS = MOM6 Makefile path_names # Compiler flags # Conditionally build symmetric with coverage support -COVERAGE=$(if $(REPORT_COVERAGE),"$(FCFLAGS_COVERAGE)",) +COVERAGE=$(if $(REPORT_COVERAGE),$(FCFLAGS_COVERAGE),) # .testing dependencies # TODO: We should probably build TARGET with the FMS that it was configured @@ -345,7 +345,6 @@ $(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 From d13efbe1c55d8989481ef90a6ad90379c3cecaff Mon Sep 17 00:00:00 2001 From: Rahul Mahajan Date: Thu, 8 Oct 2020 17:41:15 -0400 Subject: [PATCH 254/256] fix fieldwidth error with gfortran --- config_src/nuopc_driver/mom_cap.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ce11cfb3f9..8d48607281 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -295,7 +295,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_count + read(value, *, iostat=iostat) scalar_field_count if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldCount not an integer: "//trim(value), & @@ -311,7 +311,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx + read(value, *, iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & @@ -327,7 +327,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny + read(value, *, iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & @@ -700,16 +700,16 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !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 + 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 + 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 + endif !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") @@ -1746,7 +1746,7 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) endif else - ! restart_n is zero, restarts will be written at finalize only (no alarm control) + ! restart_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 From 38710730114452d0111214c72f274a0f8628f451 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 19 Oct 2020 17:16:12 -0400 Subject: [PATCH 255/256] Change default for USE_NET_FW_ADJUSTMENT_SIGN_BUG in drivers - The default for USE_NET_FW_ADJUSTMENT_SIGN_BUG had been changed to False but during the merge of main onto dev/gfdl the default was inadvertently flipped. @gustavo-marques pointed this out when reviewing NOAA-GFDL/MOM6#1211. - This affects EMC and NCAR versions of drivers and is not tested at GFDL. --- config_src/mct_driver/mom_surface_forcing_mct.F90 | 2 +- config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index a42a8c3015..92b5d148bb 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -1095,7 +1095,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.true.) + "the net fresh-water.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 3d49c66ce6..9ecf8bb01a 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -1094,7 +1094,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.true.) + "the net fresh-water.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& From 2c150d951f867c9793bdf7191fa76b149acb8492 Mon Sep 17 00:00:00 2001 From: Rahul Mahajan Date: Fri, 20 Nov 2020 13:47:38 -0500 Subject: [PATCH 256/256] bugfix: make the last argument in subroutine Update_Surface_Waves to be optional in src/user/MOM_wave_interface.F90. This is a bug from PR #23 bbdef39. --- src/user/MOM_wave_interface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index e9b0669f43..4ba1b779e3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -452,7 +452,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) 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 + type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables integer :: ii, jj, kk, b type(time_type) :: Day_Center