From 6628dbff5eb8220f4f2303534222f2b6b71c07dd Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 29 Feb 2024 20:20:41 -0500
Subject: [PATCH 01/30] (*)Parenthesize squares of wind stresses for FMAs
Added parentheses to expressions taking the squares of the wind stress
components in 70 lines in 7 files so that these expressions will be rotationally
invariant when fused-multiply-adds are enabled. All answers are bitwise
identical in cases without FMAs, but answers could change with FMAs.
---
.../FMS_cap/MOM_surface_forcing_gfdl.F90 | 14 ++---
.../STALE_mct_cap/mom_surface_forcing_mct.F90 | 20 +++----
.../nuopc_cap/mom_surface_forcing_nuopc.F90 | 20 +++----
.../solo_driver/MOM_surface_forcing.F90 | 56 +++++++++----------
.../solo_driver/user_surface_forcing.F90 | 4 +-
src/core/MOM_forcing_type.F90 | 10 ++--
src/user/Idealized_Hurricane.F90 | 16 +++---
7 files changed, 70 insertions(+), 70 deletions(-)
diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
index 1e56486329..97d3742749 100644
--- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
+++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
@@ -1088,10 +1088,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy,
tau_mag = 0.0 ; gustiness = CS%gust_const
if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + &
(G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then
- tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + &
- G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + &
- (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + &
- G%mask2dBu(I-1,J)*(taux_in_B(I-1,J)**2 + tauy_in_B(I-1,J)**2)) ) / &
+ tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_in_B(I,J)**2) + (tauy_in_B(I,J)**2)) + &
+ G%mask2dBu(I-1,J-1)*((taux_in_B(I-1,J-1)**2) + (tauy_in_B(I-1,J-1)**2))) + &
+ (G%mask2dBu(I,J-1)*((taux_in_B(I,J-1)**2) + (tauy_in_B(I,J-1)**2)) + &
+ G%mask2dBu(I-1,J)*((taux_in_B(I-1,J)**2) + (tauy_in_B(I-1,J)**2))) ) / &
((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) )
if (CS%read_gust_2d) gustiness = CS%gust(i,j)
endif
@@ -1105,7 +1105,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy,
enddo ; enddo
elseif (wind_stagger == AGRID) then
do j=js,je ; do i=is,ie
- tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2)
+ tau_mag = G%mask2dT(i,j) * sqrt((taux_in_A(i,j)**2) + (tauy_in_A(i,j)**2))
gustiness = CS%gust_const
if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j)
if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag)
@@ -1120,10 +1120,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy,
do j=js,je ; do i=is,ie
taux2 = 0.0 ; tauy2 = 0.0
if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) &
- taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / &
+ taux2 = (G%mask2dCu(I-1,j)*(taux_in_C(I-1,j)**2) + G%mask2dCu(I,j)*(taux_in_C(I,j)**2)) / &
(G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) &
- tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / &
+ tauy2 = (G%mask2dCv(i,J-1)*(tauy_in_C(i,J-1)**2) + G%mask2dCv(i,J)*(tauy_in_C(i,J)**2)) / &
(G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
tau_mag = sqrt(taux2 + tauy2)
diff --git a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
index bb57810f5b..720046d517 100644
--- a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
+++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
@@ -767,10 +767,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
tau_mag = 0.0 ; gustiness = CS%gust_const
if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + &
(G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then
- tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + &
- G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + &
- (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + &
- G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / &
+ tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_at_q(I,J)**2) + (tauy_at_q(I,J)**2)) + &
+ G%mask2dBu(I-1,J-1)*((taux_at_q(I-1,J-1)**2) + (tauy_at_q(I-1,J-1)**2))) + &
+ (G%mask2dBu(I,J-1)*((taux_at_q(I,J-1)**2) + (tauy_at_q(I,J-1)**2)) + &
+ G%mask2dBu(I-1,J)*((taux_at_q(I-1,J)**2) + (tauy_at_q(I-1,J)**2))) ) / &
((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) )
if (CS%read_gust_2d) gustiness = CS%gust(i,j)
endif
@@ -800,9 +800,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
do j=js,je ; do i=is,ie
gustiness = CS%gust_const
if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j)
- forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)
+ forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))
forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * &
- sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2))
+ sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2)))
enddo ; enddo
else ! C-grid wind stresses.
@@ -813,13 +813,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
do j=js,je ; do i=is,ie
taux2 = 0.0
if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) &
- taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + &
- G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
+ taux2 = (G%mask2dCu(I-1,j)*(forces%taux(I-1,j)**2) + &
+ G%mask2dCu(I,j)*(forces%taux(I,j)**2)) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
tauy2 = 0.0
if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) &
- tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + &
- G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
+ tauy2 = (G%mask2dCv(i,J-1)*(forces%tauy(i,J-1)**2) + &
+ G%mask2dCv(i,J)*(forces%tauy(i,J)**2)) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
if (CS%read_gust_2d) then
forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2)
diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
index e7d6c9abc6..5d09c58917 100644
--- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
+++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
@@ -829,10 +829,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
tau_mag = 0.0 ; gustiness = CS%gust_const
if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + &
(G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then
- tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + &
- G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + &
- (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + &
- G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / &
+ tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_at_q(I,J)**2) + (tauy_at_q(I,J)**2)) + &
+ G%mask2dBu(I-1,J-1)*((taux_at_q(I-1,J-1)**2) + (tauy_at_q(I-1,J-1)**2))) + &
+ (G%mask2dBu(I,J-1)*((taux_at_q(I,J-1)**2) + (tauy_at_q(I,J-1)**2)) + &
+ G%mask2dBu(I-1,J)*((taux_at_q(I-1,J)**2) + (tauy_at_q(I-1,J)**2))) ) / &
((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) )
if (CS%read_gust_2d) gustiness = CS%gust(i,j)
endif
@@ -862,9 +862,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
do j=js,je ; do i=is,ie
gustiness = CS%gust_const
if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j)
- forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)
+ forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))
forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * &
- sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2))
+ sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2)))
!forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j))
enddo ; enddo
call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1)
@@ -876,13 +876,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
do j=js,je ; do i=is,ie
taux2 = 0.0
if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) &
- taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + &
- G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
+ taux2 = (G%mask2dCu(I-1,j)*(forces%taux(I-1,j)**2) + &
+ G%mask2dCu(I,j)*(forces%taux(I,j)**2)) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
tauy2 = 0.0
if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) &
- tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + &
- G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
+ tauy2 = (G%mask2dCv(i,J-1)*(forces%tauy(i,J-1)**2) + &
+ G%mask2dCv(i,J)*(forces%tauy(i,J)**2)) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
if (CS%read_gust_2d) then
forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2)
diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90
index 3de43eec85..b2d92c00e7 100644
--- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90
+++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90
@@ -533,13 +533,13 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS)
! set the friction velocity
if (CS%answer_date < 20190101) then
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
- forces%tau_mag(i,j) = 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)))
+ forces%tau_mag(i,j) = 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))))
enddo ; enddo ; endif
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) + &
- 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) )
+ 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
else
call stresses_to_ustar(forces, G, US, CS)
@@ -743,19 +743,19 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS)
if (.not.read_Ustar) then
if (CS%read_gust_2d) then
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
- forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)
+ forces%tau_mag(i,j) = CS%gust(i,j) + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2))
enddo ; enddo ; endif
if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie
- tau_mag = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)
+ tau_mag = CS%gust(i,j) + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2))
forces%ustar(i,j) = sqrt(tau_mag * US%L_to_Z / CS%Rho0)
enddo ; enddo ; endif
else
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
- forces%tau_mag(i,j) = CS%gust_const + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)
+ forces%tau_mag(i,j) = CS%gust_const + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2))
enddo ; enddo ; endif
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 + &
- sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) )
+ sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) / CS%Rho0) )
enddo ; enddo ; endif
endif
endif
@@ -797,25 +797,25 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS)
if (CS%read_gust_2d) then
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = 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)))
+ 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))))
enddo ; enddo ; endif
if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie
tau_mag = 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)))
+ 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))))
forces%ustar(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 )
enddo ; enddo ; endif
else
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = 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)))
+ 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))))
enddo ; enddo ; endif
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) + &
- 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))
+ 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
endif
endif
@@ -885,21 +885,21 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS)
if (CS%read_gust_2d) then
call data_override(G%Domain, 'gust', CS%gust, day, scale=US%Pa_to_RLZ_T2)
if (associated(forces%tau_mag)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec
- forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j)
+ forces%tau_mag(i,j) = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j)
enddo ; enddo ; endif
do j=G%jsc,G%jec ; do i=G%isc,G%iec
- tau_mag = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j)
+ tau_mag = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j)
ustar_loc(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 )
enddo ; enddo
else
if (associated(forces%tau_mag)) then
do j=G%jsc,G%jec ; do i=G%isc,G%iec
- forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust_const
+ forces%tau_mag(i,j) = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust_const
! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 )
enddo ; enddo
endif
do j=G%jsc,G%jec ; do i=G%isc,G%iec
- ustar_loc(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + &
+ ustar_loc(i,j) = sqrt(US%L_to_Z * (sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2))/CS%Rho0 + &
CS%gust_const/CS%Rho0))
enddo ; enddo
endif
@@ -945,25 +945,25 @@ subroutine stresses_to_ustar(forces, G, US, CS)
if (CS%read_gust_2d) then
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = 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)))
+ 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))))
enddo ; enddo ; endif
if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie
tau_mag = 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)))
+ 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))))
forces%ustar(i,j) = sqrt( tau_mag * I_rho )
enddo ; enddo ; endif
else
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = 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)))
+ 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))))
enddo ; enddo ; endif
if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie
tau_mag = 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)))
+ 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))))
forces%ustar(i,j) = sqrt( tau_mag * I_rho )
enddo ; enddo ; endif
endif
diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90
index 7d4ea94603..559291b225 100644
--- a/config_src/drivers/solo_driver/user_surface_forcing.F90
+++ b/config_src/drivers/solo_driver/user_surface_forcing.F90
@@ -91,8 +91,8 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS)
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%tau_mag(i,j) = G%mask2dT(i,j) * (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)))
+ 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))))
if (associated(forces%ustar)) &
forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0))
enddo ; enddo ; endif
diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90
index 72c67253ed..02855c9fe6 100644
--- a/src/core/MOM_forcing_type.F90
+++ b/src/core/MOM_forcing_type.F90
@@ -2425,13 +2425,13 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0)
do j=js,je ; do i=is,ie
taux2 = 0.0
if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) &
- taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + &
- G%mask2dCu(I,j) * forces%taux(I,j)**2) / &
+ taux2 = (G%mask2dCu(I-1,j) * (forces%taux(I-1,j)**2) + &
+ G%mask2dCu(I,j) * (forces%taux(I,j)**2)) / &
(G%mask2dCu(I-1,j) + G%mask2dCu(I,j))
tauy2 = 0.0
if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) &
- tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + &
- G%mask2dCv(i,J) * forces%tauy(i,J)**2) / &
+ tauy2 = (G%mask2dCv(i,J-1) * (forces%tauy(i,J-1)**2) + &
+ G%mask2dCv(i,J) * (forces%tauy(i,J)**2)) / &
(G%mask2dCv(i,J-1) + G%mask2dCv(i,J))
if (associated(fluxes%ustar_gustless)) then
@@ -3822,7 +3822,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar)
if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean
enddo ; enddo
if (tau2ustar) then
- tau_mag = sqrt(tx_mean**2 + ty_mean**2)
+ tau_mag = sqrt((tx_mean**2) + (ty_mean**2))
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then
forces%tau_mag(i,j) = tau_mag
endif ; enddo ; enddo ; endif
diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90
index 0c9d5cd330..8028af9667 100644
--- a/src/user/Idealized_Hurricane.F90
+++ b/src/user/Idealized_Hurricane.F90
@@ -312,15 +312,15 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS)
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%gustiness/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))
+ 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
!> Get tau_mag [R L Z T-2 ~> Pa]
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + &
- 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)))
+ 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))))
enddo ; enddo ; endif
end subroutine idealized_hurricane_wind_forcing
@@ -660,15 +660,15 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C
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%gustiness/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))
+ 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
!> Set magnitude of the wind stress [R L Z T-2 ~> Pa]
if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie
forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + &
- 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)))
+ 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))))
enddo ; enddo ; endif
end subroutine SCM_idealized_hurricane_wind_forcing
From f0e61f30cc0cdc584aac6b8a14af0cc46ba9c5ab Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 29 Feb 2024 14:00:52 -0500
Subject: [PATCH 02/30] (*)Parenthesize continuity_PPM curv_3 expressions
Added parentheses to 9 expressions like `curv_3 = h_W(i) + h_E(i) - 2.0*h(i)`
in PPM_limit_pos, zonal_flux_layer, zonal_flux_thickness, merid_flux_layer and
merid_flux_thickness, changing them to `curv_3 = (h_W(i) + h_E(i)) - 2.0*h(i)`.
This change enforces the order of arithmetic that is required to give rotational
symmetry, but it also is the order that the Intel, GNU, and Nvidia compliers
were all already using in these expressions. Moreover, had the order of
arithmetic ever been anything else, this would have led to failures in our
rotational consistency and redundant point consistency testing, and almost
certainly would have been detected before. However, by adding these parentheses,
there is a remote chance that the addition of these parentheses could change
answers for some compiler or compiler settings we have never tested before.
This change should not impact any FMA-enabled calculations. All answers are
bitwise identical in the MOM6-examples regression suite as run on Gaea.
---
src/core/MOM_continuity_PPM.F90 | 18 +++++++++---------
1 file changed, 9 insertions(+), 9 deletions(-)
diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90
index ba8c234bc2..13181902ec 100644
--- a/src/core/MOM_continuity_PPM.F90
+++ b/src/core/MOM_continuity_PPM.F90
@@ -937,14 +937,14 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, &
if (u(I) > 0.0) then
if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif
- curv_3 = h_W(i) + h_E(i) - 2.0*h(i)
+ curv_3 = (h_W(i) + h_E(i)) - 2.0*h(i)
uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * &
(h_E(i) + CFL * (0.5*(h_W(i) - h_E(i)) + curv_3*(CFL - 1.5)))
h_marg = h_E(i) + CFL * ((h_W(i) - h_E(i)) + 3.0*curv_3*(CFL - 1.0))
elseif (u(I) < 0.0) then
if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif
- curv_3 = h_W(i+1) + h_E(i+1) - 2.0*h(i+1)
+ curv_3 = (h_W(i+1) + h_E(i+1)) - 2.0*h(i+1)
uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * &
(h_W(i+1) + CFL * (0.5*(h_E(i+1)-h_W(i+1)) + curv_3*(CFL - 1.5)))
h_marg = h_W(i+1) + CFL * ((h_E(i+1)-h_W(i+1)) + 3.0*curv_3*(CFL - 1.0))
@@ -1019,13 +1019,13 @@ subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL,
if (u(I,j,k) > 0.0) then
if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif
- curv_3 = h_W(i,j,k) + h_E(i,j,k) - 2.0*h(i,j,k)
+ curv_3 = (h_W(i,j,k) + h_E(i,j,k)) - 2.0*h(i,j,k)
h_avg = h_E(i,j,k) + CFL * (0.5*(h_W(i,j,k) - h_E(i,j,k)) + curv_3*(CFL - 1.5))
h_marg = h_E(i,j,k) + CFL * ((h_W(i,j,k) - h_E(i,j,k)) + 3.0*curv_3*(CFL - 1.0))
elseif (u(I,j,k) < 0.0) then
if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif
- curv_3 = h_W(i+1,j,k) + h_E(i+1,j,k) - 2.0*h(i+1,j,k)
+ curv_3 = (h_W(i+1,j,k) + h_E(i+1,j,k)) - 2.0*h(i+1,j,k)
h_avg = h_W(i+1,j,k) + CFL * (0.5*(h_E(i+1,j,k)-h_W(i+1,j,k)) + curv_3*(CFL - 1.5))
h_marg = h_W(i+1,j,k) + CFL * ((h_E(i+1,j,k)-h_W(i+1,j,k)) + &
3.0*curv_3*(CFL - 1.0))
@@ -1832,7 +1832,7 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, &
if (v(i) > 0.0) then
if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif
- curv_3 = h_S(i,j) + h_N(i,j) - 2.0*h(i,j)
+ curv_3 = (h_S(i,j) + h_N(i,j)) - 2.0*h(i,j)
vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_N(i,j) + CFL * &
(0.5*(h_S(i,j) - h_N(i,j)) + curv_3*(CFL - 1.5)) )
h_marg = h_N(i,j) + CFL * ((h_S(i,j) - h_N(i,j)) + &
@@ -1840,7 +1840,7 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, &
elseif (v(i) < 0.0) then
if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif
- curv_3 = h_S(i,j+1) + h_N(i,j+1) - 2.0*h(i,j+1)
+ curv_3 = (h_S(i,j+1) + h_N(i,j+1)) - 2.0*h(i,j+1)
vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_S(i,j+1) + CFL * &
(0.5*(h_N(i,j+1)-h_S(i,j+1)) + curv_3*(CFL - 1.5)) )
h_marg = h_S(i,j+1) + CFL * ((h_N(i,j+1)-h_S(i,j+1)) + &
@@ -1919,14 +1919,14 @@ subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol
if (v(i,J,k) > 0.0) then
if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif
- curv_3 = h_S(i,j,k) + h_N(i,j,k) - 2.0*h(i,j,k)
+ curv_3 = (h_S(i,j,k) + h_N(i,j,k)) - 2.0*h(i,j,k)
h_avg = h_N(i,j,k) + CFL * (0.5*(h_S(i,j,k) - h_N(i,j,k)) + curv_3*(CFL - 1.5))
h_marg = h_N(i,j,k) + CFL * ((h_S(i,j,k) - h_N(i,j,k)) + &
3.0*curv_3*(CFL - 1.0))
elseif (v(i,J,k) < 0.0) then
if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif
- curv_3 = h_S(i,j+1,k) + h_N(i,j+1,k) - 2.0*h(i,j+1,k)
+ curv_3 = (h_S(i,j+1,k) + h_N(i,j+1,k)) - 2.0*h(i,j+1,k)
h_avg = h_S(i,j+1,k) + CFL * (0.5*(h_N(i,j+1,k)-h_S(i,j+1,k)) + curv_3*(CFL - 1.5))
h_marg = h_S(i,j+1,k) + CFL * ((h_N(i,j+1,k)-h_S(i,j+1,k)) + &
3.0*curv_3*(CFL - 1.0))
@@ -2601,7 +2601,7 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie)
do j=jis,jie ; do i=iis,iie
! This limiter prevents undershooting minima within the domain with
! values less than h_min.
- curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j))
+ curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j))
if (curv > 0.0) then ! Only minima are limited.
dh = h_R(i,j) - h_L(i,j)
if (abs(dh) < curv) then ! The parabola's minimum is within the cell.
From 4f710efb0ad8481760517bda7a702670c917b8b8 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 29 Feb 2024 20:43:14 -0500
Subject: [PATCH 03/30] (*)Add parentheses for oblique OBCs with FMAs
Added parentheses to 16 expressions setting the grad_gradient arrays with
oblique_grad open boundary conditions and setting cff_new with all kinds of
oblique boundary conditions so that they will be rotationally invariant when
fused-multiply-adds are enabled. All answers are bitwise identical in cases
without FMAs, but answers with certain types of open boundary conditions could
change with FMAs.
---
src/core/MOM_open_boundary.F90 | 32 ++++++++++++++++----------------
1 file changed, 16 insertions(+), 16 deletions(-)
diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90
index 8394735cb9..4dcbad4388 100644
--- a/src/core/MOM_open_boundary.F90
+++ b/src/core/MOM_open_boundary.F90
@@ -2359,7 +2359,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdy = segment%grad_normal(J,1,k)
endif
if (dhdt*dhdx < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
rx_new = min(dhdt*dhdx, cff_new*rx_max)
ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
if (gamma_u < 1.0) then
@@ -2501,7 +2501,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdy = segment%grad_tan(j+1,1,k)
endif
if (dhdt*dhdx < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
rx_new = min(dhdt*dhdx, cff_new*rx_max)
ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
rx_tang_obl(I,J,k) = rx_new
@@ -2604,7 +2604,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
endif
if (dhdt*dhdx < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
rx_new = min(dhdt*dhdx, cff_new*rx_max)
ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
if (gamma_u < 1.0) then
@@ -2746,7 +2746,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdy = segment%grad_tan(j+1,1,k)
endif
if (dhdt*dhdx < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
rx_new = min(dhdt*dhdx, cff_new*rx_max)
ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
rx_tang_obl(I,J,k) = rx_new
@@ -2848,7 +2848,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdx = segment%grad_normal(I,1,k)
endif
if (dhdt*dhdy < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
ry_new = min(dhdt*dhdy, cff_new*ry_max)
rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
if (gamma_u < 1.0) then
@@ -2990,7 +2990,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdx = segment%grad_tan(i+1,1,k)
endif
if (dhdt*dhdy < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
ry_new = min(dhdt*dhdy, cff_new*ry_max)
rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
rx_tang_obl(I,J,k) = rx_new
@@ -3093,7 +3093,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
endif
if (dhdt*dhdy < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
ry_new = min(dhdt*dhdy, cff_new*ry_max)
rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
if (gamma_u < 1.0) then
@@ -3235,7 +3235,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
dhdx = segment%grad_tan(i+1,1,k)
endif
if (dhdt*dhdy < 0.0) dhdt = 0.0
- cff_new = max(dhdx*dhdx + dhdy*dhdy, eps)
+ cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
ry_new = min(dhdt*dhdy, cff_new*ry_max)
rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
rx_tang_obl(I,J,k) = rx_new
@@ -3435,9 +3435,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
do k=1,GV%ke
do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1)
segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - &
- (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j)
+ ((vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1))) * G%mask2dCu(I-2,j)
segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - &
- (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I-1,j)
+ ((vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1))) * G%mask2dCu(I-1,j)
enddo
enddo
endif
@@ -3461,9 +3461,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
do k=1,GV%ke
do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1)
segment%grad_gradient(j,1,k) = (((vvel(i+3,J,k) - vvel(i+2,J,k))*G%IdxBu(I+2,J)) - &
- (vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1)) * G%mask2dCu(I+2,j)
+ ((vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1))) * G%mask2dCu(I+2,j)
segment%grad_gradient(j,2,k) = (((vvel(i+2,J,k) - vvel(i+1,J,k))*G%IdxBu(I+1,J)) - &
- (vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1)) * G%mask2dCu(I+1,j)
+ ((vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1))) * G%mask2dCu(I+1,j)
enddo
enddo
endif
@@ -3489,9 +3489,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
do k=1,GV%ke
do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1)
segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - &
- (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2)
+ ((uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2))) * G%mask2dCv(i,J-2)
segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - &
- (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J-1)
+ ((uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1))) * G%mask2dCv(i,J-1)
enddo
enddo
endif
@@ -3515,9 +3515,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
do k=1,GV%ke
do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1)
segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - &
- (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2)
+ ((uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2))) * G%mask2dCv(i,J+2)
segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdyBu(I,J+1)) - &
- (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1)
+ ((uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1))) * G%mask2dCv(i,J+1)
enddo
enddo
endif
From 9172cd57608bd4c567c7a371958b00a362a7f699 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 29 Feb 2024 22:00:29 -0500
Subject: [PATCH 04/30] (*)Add parentheses for density_integrals with FMAs
Added parentheses to 150 lines in the 5 generic density integral routines
(int_density_dz_generic_pcm, int_density_dz_generic_plm,
int_density_dz_generic_ppm, int_spec_vol_dp_generic_pcm and
int_spec_vol_dp_generic_plm) in the MOM_density_integrals module so that they
will be rotationally invariant when fused-multiply-adds are enabled. All
answers are bitwise identical in cases without FMAs, but answers could change
with FMAs.
---
src/core/MOM_density_integrals.F90 | 288 ++++++++++++++---------------
1 file changed, 144 insertions(+), 144 deletions(-)
diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90
index 6d80d4dd55..5505d49bfe 100644
--- a/src/core/MOM_density_integrals.F90
+++ b/src/core/MOM_density_integrals.F90
@@ -243,9 +243,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -254,12 +254,12 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
! 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_x(m,i) = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j))
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
+ dz_x(m,i) = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
pos = i*15+(m-2)*5
- T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i+1,j)
- S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i+1,j)
- p15(pos+1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - z0pres)
+ T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j))
+ S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j))
+ p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - z0pres)
do n=2,5
T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1)
p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i)
@@ -309,9 +309,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -320,12 +320,12 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
! 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_y(m,i) = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1))
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
+ dz_y(m,i) = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
pos = i*15+(m-2)*5
- T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i,j+1)
- S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i,j+1)
- p15(pos+1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - z0pres)
+ T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1))
+ S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1))
+ p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - z0pres)
do n=2,5
T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1)
p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i)
@@ -584,15 +584,15 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + (hL*hR) )
+ 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,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)
@@ -600,20 +600,20 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
do m=2,4
w_left = wt_t(m) ; w_right = wt_b(m)
- 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))
+ 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
! 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
+ T15(pos+1) = (w_left*Ttl) + (w_right*Ttr)
+ T15(pos+5) = (w_left*Tbl) + (w_right*Tbr)
- S15(pos+1) = w_left*Stl + w_right*Str
- S15(pos+5) = w_left*Sbl + w_right*Sbr
+ S15(pos+1) = (w_left*Stl) + (w_right*Str)
+ S15(pos+5) = (w_left*Sbl) + (w_right*Sbr)
- p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres)
+ p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres)
! Pressure
do n=2,5
@@ -625,9 +625,9 @@ 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)
+ 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
@@ -648,14 +648,14 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
if (use_rho_ref) then
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)) )
+ 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
else
do m = 2,4
pos = i*15+(m-2)*5
- intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + &
- 12.0*r15(pos+3)) - rho_ref )
+ intz(m) = (G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + &
+ 12.0*r15(pos+3)) - rho_ref ))
enddo
endif
! Use Boole's rule to integrate the bottom pressure anomaly values in x.
@@ -680,15 +680,15 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + (hL*hR) )
+ 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,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)
@@ -696,20 +696,20 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
do m=2,4
w_left = wt_t(m) ; w_right = wt_b(m)
- 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))
+ 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
! 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
+ T15(pos+1) = (w_left*Ttl) + (w_right*Ttr)
+ T15(pos+5) = (w_left*Tbl) + (w_right*Tbr)
- S15(pos+1) = w_left*Stl + w_right*Str
- S15(pos+5) = w_left*Sbl + w_right*Sbr
+ S15(pos+1) = (w_left*Stl) + (w_right*Str)
+ S15(pos+5) = (w_left*Sbl) + (w_right*Sbr)
- p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres)
+ p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres)
! Pressure
do n=2,5
@@ -721,9 +721,9 @@ 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)
+ 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
@@ -748,16 +748,16 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
if (use_rho_ref) then
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)) + &
+ 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)) )
+ 12.0*r15(pos+3)) ))
enddo
else
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)) + &
+ intz(m) = (G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + &
32.0*(r15(pos+2)+r15(pos+4)) + &
- 12.0*r15(pos+3)) - rho_ref )
+ 12.0*r15(pos+3)) - rho_ref ))
enddo
endif
! Use Boole's rule to integrate the values.
@@ -977,19 +977,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + (hL*hR) )
+ 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,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)
@@ -1004,19 +1004,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
! 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
+ T_top = (w_left*Ttl) + (w_right*Ttr)
+ T_mn = (w_left*Tml) + (w_right*Tmr)
+ T_bot = (w_left*Tbl) + (w_right*Tbr)
- S_top = w_left*Stl + w_right*Str
- S_mn = w_left*Sml + w_right*Smr
- S_bot = w_left*Sbl + w_right*Sbr
+ 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_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))
+ 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)))
pos = i*15+(m-2)*5
- p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres)
+ p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres)
do n=2,5
p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i)
enddo
@@ -1032,9 +1032,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
T15(pos+n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) )
enddo
if (use_stanley_eos) then
- 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)
+ 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))
endif
if (use_stanley_eos) then
call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref)
@@ -1082,19 +1082,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + (hL*hR) )
+ 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,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)
@@ -1109,19 +1109,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
! 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
+ T_top = (w_left*Ttl) + (w_right*Ttr)
+ T_mn = (w_left*Tml) + (w_right*Tmr)
+ T_bot = (w_left*Tbl) + (w_right*Tbr)
- S_top = w_left*Stl + w_right*Str
- S_mn = w_left*Sml + w_right*Smr
- S_bot = w_left*Sbl + w_right*Sbr
+ 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_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))
+ 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)))
pos = i*15+(m-2)*5
- p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres)
+ p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres)
do n=2,5
p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i)
enddo
@@ -1138,9 +1138,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
enddo
if (use_stanley_eos) then
- 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)
+ 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))
endif
enddo
enddo
@@ -1372,24 +1372,24 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
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
+ 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
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
pos = i*15+(m-2)*5
! T, S, and p are interpolated in the horizontal. The p interpolation
! is linear, but for T and S it may be thickness weighted.
- p15(pos+1) = wt_L*p_b(i,j) + wt_R*p_b(i+1,j)
- dp_x(m,I) = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j))
- T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i+1,j)
- S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i+1,j)
+ p15(pos+1) = (wt_L*p_b(i,j)) + (wt_R*p_b(i+1,j))
+ dp_x(m,I) = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j)))
+ T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j))
+ S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j))
do n=2,5
T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1)
@@ -1427,24 +1427,24 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
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
+ 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
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
pos = i*15+(m-2)*5
! T, S, and p are interpolated in the horizontal. The p interpolation
! is linear, but for T and S it may be thickness weighted.
- p15(pos+1) = wt_L*p_b(i,j) + wt_R*p_b(i,j+1)
- dp_y(m,i) = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1))
- T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i,j+1)
- S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i,j+1)
+ p15(pos+1) = (wt_L*p_b(i,j)) + (wt_R*p_b(i,j+1))
+ dp_y(m,i) = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1)))
+ T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1))
+ S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1))
do n=2,5
T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1)
p15(pos+n) = p15(pos+n-1) - 0.25*dp_y(m,i)
@@ -1613,25 +1613,25 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
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
+ 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
+ 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)
+ 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,I) = C1_90*(P_bot - P_top)
! Salinity, temperature and pressure with linear interpolation in the vertical.
@@ -1674,25 +1674,25 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
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
+ 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
+ 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)
+ 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,i) = C1_90*(P_bot - P_top)
! Salinity, temperature and pressure with linear interpolation in the vertical.
From 24091ccf02f61b92e7db1f4ac6b3d3a1d3036881 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 29 Feb 2024 22:53:14 -0500
Subject: [PATCH 05/30] (*)Add parentheses to 4 EOS int_density routines
Added parentheses to 140 lines in 8 int_density_dz and int_spec_vol_dp
routines for the linear, Wright, Wright_full and Wright_red equations of state
so that they will be rotationally invariant when fused-multiply-adds are
enabled. All answers are bitwise identical in cases without FMAs, but answers
could change with FMAs.
---
src/equation_of_state/MOM_EOS_Wright.F90 | 72 +++++++++----------
src/equation_of_state/MOM_EOS_Wright_full.F90 | 72 +++++++++----------
src/equation_of_state/MOM_EOS_Wright_red.F90 | 72 +++++++++----------
src/equation_of_state/MOM_EOS_linear.F90 | 64 ++++++++---------
4 files changed, 140 insertions(+), 140 deletions(-)
diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90
index d4b091b7b2..4cbaa8eeae 100644
--- a/src/equation_of_state/MOM_EOS_Wright.F90
+++ b/src/equation_of_state/MOM_EOS_Wright.F90
@@ -568,9 +568,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -578,14 +578,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
@@ -609,9 +609,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -619,14 +619,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
@@ -808,9 +808,9 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -818,16 +818,16 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j))))
eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps
intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* &
@@ -849,9 +849,9 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -859,16 +859,16 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1)
- p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1)
- lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1)
+ al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1))
+ p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1))
+ lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1))))
eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps
intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* &
diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90
index 31b82e6190..4ea6930c46 100644
--- a/src/equation_of_state/MOM_EOS_Wright_full.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_full.F90
@@ -573,9 +573,9 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -583,14 +583,14 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0)
@@ -614,9 +614,9 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -624,14 +624,14 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0)
@@ -815,9 +815,9 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -825,16 +825,16 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j))))
I_pterm = 1.0 / (p0 + p_ave)
eps = 0.5 * dp * I_pterm ; eps2 = eps*eps
@@ -857,9 +857,9 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -867,16 +867,16 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1)
- p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1)
- lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1)
+ al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1))
+ p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1))
+ lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1))))
I_pterm = 1.0 / (p0 + p_ave)
eps = 0.5 * dp * I_pterm ; eps2 = eps*eps
diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90
index 65bdb9e521..ed5eaf7b23 100644
--- a/src/equation_of_state/MOM_EOS_Wright_red.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_red.F90
@@ -575,9 +575,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -585,14 +585,14 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0)
@@ -616,9 +616,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -626,14 +626,14 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1))
- dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1))
- p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres)
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
+ p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres)
I_al0 = 1.0 / al0
I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0)
@@ -817,9 +817,9 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -827,16 +827,16 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j)
- p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j)
- lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j)
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j))))
I_pterm = 1.0 / (p0 + p_ave)
eps = 0.5 * dp * I_pterm ; eps2 = eps*eps
@@ -859,9 +859,9 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -869,16 +869,16 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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.
- al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1)
- p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1)
- lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1)
+ al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1))
+ p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1))
+ lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1))
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1))
- p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1)))
+ dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1)))
+ p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1))))
I_pterm = 1.0 / (p0 + p_ave)
eps = 0.5 * dp * I_pterm ; eps2 = eps*eps
diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90
index 8984fbca88..1b9d5b7597 100644
--- a/src/equation_of_state/MOM_EOS_linear.F90
+++ b/src/equation_of_state/MOM_EOS_linear.F90
@@ -356,24 +356,24 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, &
raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j))
raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j))
- intx_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL))
+ intx_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL)))
else
hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + (hL*hR) )
+ hWt_LL = (hWght*hL + (hR*hL)) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + (hR*hL)) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ 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))
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
rho_anom = (Rho_T0_S0 - rho_ref) + &
- (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i+1,j)) + &
- dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i+1,j)))
+ (dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + &
+ dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i+1,j))))
intz(m) = G_e*rho_anom*dz
enddo
! Use Boole's rule to integrate the values.
@@ -395,24 +395,24 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, &
raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j))
raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1))
- inty_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL))
+ inty_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL)))
else
hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + (hL*hR) )
+ hWt_LL = (hWght*hL + (hR*hL)) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + (hR*hL)) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intz(1) = dpa(i,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
+ 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))
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
rho_anom = (Rho_T0_S0 - rho_ref) + &
- (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i,j+1)) + &
- dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i,j+1)))
+ (dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + &
+ dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i,j+1))))
intz(m) = G_e*rho_anom*dz
enddo
! Use Boole's rule to integrate the values.
@@ -530,26 +530,26 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, &
dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)
aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS)
- intx_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL))
+ intx_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL)))
else
hL = (p_b(i,j) - p_t(i,j)) + dP_neglect
hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect
hWght = hWght * ( (hL-hR)/(hL+hR) )**2
- iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
- hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
- hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
+ iDenom = 1.0 / ( hWght*(hR + hL) + (hL*hR) )
+ hWt_LL = (hWght*hL + (hR*hL)) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + (hR*hL)) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intp(1) = dza(i,j) ; intp(5) = dza(i+1,j)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ 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.
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(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)))
- dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i+1,j)) + &
- dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i+1,j))
+ dRho_TS = dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + &
+ dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))
! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref
alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS)
intp(m) = alpha_anom*dp
@@ -575,26 +575,26 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, &
dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)
aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS)
- inty_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL))
+ inty_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL)))
else
hL = (p_b(i,j) - p_t(i,j)) + dP_neglect
hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect
hWght = hWght * ( (hL-hR)/(hL+hR) )**2
- iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
- hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
- hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
+ iDenom = 1.0 / ( hWght*(hR + hL) + (hL*hR) )
+ hWt_LL = (hWght*hL + (hR*hL)) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + (hR*hL)) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intp(1) = dza(i,j) ; intp(5) = dza(i,j+1)
do m=2,4
wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR
+ 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.
- dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(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)))
- dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i,j+1)) + &
- dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i,j+1))
+ dRho_TS = dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + &
+ dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))
! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref
alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS)
intp(m) = alpha_anom*dp
From 8066a3da0d313b3f8154ba06126b5e7ffc257574 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Mon, 4 Mar 2024 08:46:26 -0500
Subject: [PATCH 06/30] (*)Simplify density integral parentheses
Removed recently added parentheses around expressions like '+ (hL*hR)' in 110
lines in MOM_density_integrals and 4 equation of state module to reflect that
these parentheses are not necessary for rotational symmetry in
FMAs. All answers are bitwise identical in cases without FMAs, but
answers could change with FMAs.
---
src/core/MOM_density_integrals.F90 | 124 +++++++++---------
src/equation_of_state/MOM_EOS_Wright.F90 | 24 ++--
src/equation_of_state/MOM_EOS_Wright_full.F90 | 24 ++--
src/equation_of_state/MOM_EOS_Wright_red.F90 | 24 ++--
src/equation_of_state/MOM_EOS_linear.F90 | 24 ++--
5 files changed, 110 insertions(+), 110 deletions(-)
diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90
index 5505d49bfe..5b50c5b57d 100644
--- a/src/core/MOM_density_integrals.F90
+++ b/src/core/MOM_density_integrals.F90
@@ -243,9 +243,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -309,9 +309,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -584,15 +584,15 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + hL*hR )
+ 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,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)
@@ -680,15 +680,15 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + hL*hR )
+ 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,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)
@@ -977,19 +977,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + hL*hR )
+ 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,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)
@@ -1082,19 +1082,19 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
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,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
+ iDenom = 1./( hWght*(hR + hL) + hL*hR )
+ 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,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)
@@ -1372,9 +1372,9 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
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
+ 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
@@ -1427,9 +1427,9 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
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
+ 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
@@ -1613,9 +1613,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
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
+ 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
@@ -1674,9 +1674,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
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
+ 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
diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90
index 4cbaa8eeae..38eeab7c81 100644
--- a/src/equation_of_state/MOM_EOS_Wright.F90
+++ b/src/equation_of_state/MOM_EOS_Wright.F90
@@ -568,9 +568,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -609,9 +609,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -808,9 +808,9 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -849,9 +849,9 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90
index 4ea6930c46..41d3608db7 100644
--- a/src/equation_of_state/MOM_EOS_Wright_full.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_full.F90
@@ -573,9 +573,9 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -614,9 +614,9 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -815,9 +815,9 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -857,9 +857,9 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90
index ed5eaf7b23..dc637e6700 100644
--- a/src/equation_of_state/MOM_EOS_Wright_red.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_red.F90
@@ -575,9 +575,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -616,9 +616,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
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
+ 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
@@ -817,9 +817,9 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
@@ -859,9 +859,9 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
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
+ 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
diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90
index 1b9d5b7597..490885aacc 100644
--- a/src/equation_of_state/MOM_EOS_linear.F90
+++ b/src/equation_of_state/MOM_EOS_linear.F90
@@ -361,9 +361,9 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, &
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
do m=2,4
@@ -400,9 +400,9 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, &
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1)
do m=2,4
@@ -535,9 +535,9 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, &
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intp(1) = dza(i,j) ; intp(5) = dza(i+1,j)
do m=2,4
@@ -580,9 +580,9 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, &
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
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
intp(1) = dza(i,j) ; intp(5) = dza(i,j+1)
do m=2,4
From 99fd9579698576869a70ee79502a05e663d26fab Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 06:50:32 -0500
Subject: [PATCH 07/30] (*)Parenthesize PressureForce_Montgomery for FMAs
Added parentheses to 4 lines in PressureForce_Mont_nonBouss and
PressureForce_Mont_Bouss so that they will be rotationally invariant when
fused-multiply-adds are enabled. All answers are bitwise identical in cases
without FMAs, but answers could change with FMAs in cases that use the
Montgomery potential form of the pressure gradient accelerations.
---
src/core/MOM_PressureForce_Montgomery.F90 | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90
index 6d982bc7e3..1529af9d83 100644
--- a/src/core/MOM_PressureForce_Montgomery.F90
+++ b/src/core/MOM_PressureForce_Montgomery.F90
@@ -337,14 +337,14 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb
do j=js,je ; do I=Isq,Ieq
! PFu_bc = p* grad alpha*
PFu_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * &
- ((dp_star(i,j)*dp_star(i+1,j) + (p(i,j,K)*dp_star(i+1,j) + p(i+1,j,K)*dp_star(i,j))) / &
+ ((dp_star(i,j)*dp_star(i+1,j) + ((p(i,j,K)*dp_star(i+1,j)) + (p(i+1,j,K)*dp_star(i,j)))) / &
(dp_star(i,j) + dp_star(i+1,j))))
PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc
if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc
enddo ; enddo
do J=Jsq,Jeq ; do i=is,ie
PFv_bc = (alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * &
- ((dp_star(i,j)*dp_star(i,j+1) + (p(i,j,K)*dp_star(i,j+1) + p(i,j+1,K)*dp_star(i,j))) / &
+ ((dp_star(i,j)*dp_star(i,j+1) + ((p(i,j,K)*dp_star(i,j+1)) + (p(i,j+1,K)*dp_star(i,j)))) / &
(dp_star(i,j) + dp_star(i,j+1))))
PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc
if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc
@@ -586,15 +586,15 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce,
enddo ; enddo
do j=js,je ; do I=Isq,Ieq
PFu_bc = -1.0*(rho_star(i+1,j,k) - rho_star(i,j,k)) * (G%IdxCu(I,j) * &
- ((h_star(i,j) * h_star(i+1,j) - (e(i,j,K) * h_star(i+1,j) + &
- e(i+1,j,K) * h_star(i,j))) / (h_star(i,j) + h_star(i+1,j))))
+ ((h_star(i,j) * h_star(i+1,j) - ((e(i,j,K) * h_star(i+1,j)) + &
+ (e(i+1,j,K) * h_star(i,j)))) / (h_star(i,j) + h_star(i+1,j))))
PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc
if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc
enddo ; enddo
do J=Jsq,Jeq ; do i=is,ie
PFv_bc = -1.0*(rho_star(i,j+1,k) - rho_star(i,j,k)) * (G%IdyCv(i,J) * &
- ((h_star(i,j) * h_star(i,j+1) - (e(i,j,K) * h_star(i,j+1) + &
- e(i,j+1,K) * h_star(i,j))) / (h_star(i,j) + h_star(i,j+1))))
+ ((h_star(i,j) * h_star(i,j+1) - ((e(i,j,K) * h_star(i,j+1)) + &
+ (e(i,j+1,K) * h_star(i,j)))) / (h_star(i,j) + h_star(i,j+1))))
PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc
if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc
enddo ; enddo
From 307a4e2e55bc3ab54a9fd95e861db4d669f7bc6d Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 07:04:47 -0500
Subject: [PATCH 08/30] (*)Parenthesize calc_isoneutral_slopes for FMAs
Added parentheses to 4 lines in calc_isoneutral_slopes so that they will be rotationally invariant when
fused-multiply-adds are enabled. All answers are bitwise identical in cases
without FMAs, but answers could change with FMAs.
---
src/core/MOM_isopycnal_slopes.F90 | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90
index 9defa597ab..ede5137cb6 100644
--- a/src/core/MOM_isopycnal_slopes.F90
+++ b/src/core/MOM_isopycnal_slopes.F90
@@ -334,7 +334,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan
wtA = hg2A*haB ; wtB = hg2B*haA
wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL)
- drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR)
+ drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR))
! The expression for drdz above is mathematically equivalent to:
! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / &
! ((hg2L/haL) + (hg2R/haR))
@@ -376,8 +376,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan
endif
slope_x(I,j,K) = slope
if (present(dzSxN)) &
- dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., wtL * ( dzaL * drdkL ) &
- + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N
+ dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., (wtL * ( dzaL * drdkL )) &
+ + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N
* abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2
enddo ! I
@@ -485,7 +485,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan
wtA = hg2A*haB ; wtB = hg2B*haA
wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL)
- drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR)
+ drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR))
! The expression for drdz above is mathematically equivalent to:
! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / &
! ((hg2L/haL) + (hg2R/haR))
@@ -527,8 +527,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan
endif
slope_y(i,J,K) = slope
if (present(dzSyN)) &
- dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., wtL * ( dzaL * drdkL ) &
- + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N
+ dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., (wtL * ( dzaL * drdkL )) &
+ + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N
* abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2
enddo ! i
From ce559ce64e53dd86ac225b5b703714dbfbee5881 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 07:05:09 -0500
Subject: [PATCH 09/30] (*)Parenthesize MOM_calc_varT for FMAs
Added parentheses to 2 lines in MOM_calc_varT so that they will be
rotationally invariant when fused-multiply-adds are enabled. In this case, FMAs
can still be applied to the impacted lines, exploiting that the masks are always
0 or 1. Also added parentheses to 2 other lines used to generate the stochastic
pattern for rotational symmetry with FMAs. All answers are bitwise identical in
cases without FMAs, but answers could change with FMAs.
---
src/core/MOM_stoch_eos.F90 | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90
index 2bd742be6d..909c2e9a6a 100644
--- a/src/core/MOM_stoch_eos.F90
+++ b/src/core/MOM_stoch_eos.F90
@@ -100,7 +100,7 @@ logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, resta
! fill array with approximation of grid area needed for decorrelation time-scale calculation
do j=G%jsc,G%jec
do i=G%isc,G%iec
- CS%l2_inv(i,j) = 1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2)
+ CS%l2_inv(i,j) = 1.0 / ( (G%dxT(i,j)**2) + (G%dyT(i,j)**2) )
enddo
enddo
@@ -173,7 +173,7 @@ subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS)
do i=G%isc,G%iec
ubar = 0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j))
vbar = 0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1))
- phi = exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j)))
+ phi = exp(-delt*CS%tfac * sqrt(((ubar**2) + (vbar**2))*CS%l2_inv(i,j)))
CS%pattern(i,j) = phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j)
CS%phi(i,j) = phi
enddo
@@ -233,12 +233,12 @@ subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt)
hl(5) = h(i,j+1,k) * G%mask2dCv(i,J)
! SGS variance in i-direction [C2 ~> 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) ) &
+ 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 [C2 ~> 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) ) &
+ 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
tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 )
! Turn off scheme near land
From c344a117fa0c08d8b536231e59e348cf6a78fc72 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 07:05:30 -0500
Subject: [PATCH 10/30] (*)Parenthesize tracer_hordiff for FMAs
Added parentheses to the calculation of the diffusive temperature changes in
tracer_hordiff so that it will be rotationally invariant when
fused-multiply-adds are enabled. All answers are bitwise identical in cases
without FMAs, but answers could change with FMAs.
---
src/tracer/MOM_tracer_hor_diff.F90 | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90
index 2b1530e94d..8cab315db9 100644
--- a/src/tracer/MOM_tracer_hor_diff.F90
+++ b/src/tracer/MOM_tracer_hor_diff.F90
@@ -546,10 +546,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
do m=1,ntr
do j=js,je ; do i=is,ie
dTr(i,j) = Ihdxdy(i,j) * &
- ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - &
- Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + &
- (Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - &
- Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k))))
+ ( ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k))) - &
+ (Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)))) + &
+ ((Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k))) - &
+ (Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) )
enddo ; enddo
if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB
Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) &
From b2beab215371aed0594034657c6b2d115b84f6ed Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 07:27:53 -0500
Subject: [PATCH 11/30] (*)Parenthesize iceberg_forces for FMAs
Added parentheses to the calculation of the iceberg contribution to the
fractional area of ice shelves in iceberg_forces so that it will be rotationally
invariant when fused-multiply-adds are enabled. All answers are bitwise
identical in cases without FMAs, but answers could change with FMAs enabled in
cases with tabular icebergs.
---
src/ice_shelf/MOM_marine_ice.F90 | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90
index 8635eb71b5..3fec94e499 100644
--- a/src/ice_shelf/MOM_marine_ice.F90
+++ b/src/ice_shelf/MOM_marine_ice.F90
@@ -80,7 +80,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS)
do j=js,je ; do I=is-1,ie
if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) &
forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + &
- (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i+1,j)*G%areaT(i+1,j)) / &
+ ((forces%area_berg(i,j)*G%areaT(i,j)) + (forces%area_berg(i+1,j)*G%areaT(i+1,j))) / &
(G%areaT(i,j) + G%areaT(i+1,j))
forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * &
min(forces%mass_berg(i,j), forces%mass_berg(i+1,j))
@@ -88,7 +88,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS)
do J=js-1,je ; do i=is,ie
if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) &
forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + &
- (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i,j+1)*G%areaT(i,j+1)) / &
+ ((forces%area_berg(i,j)*G%areaT(i,j)) + (forces%area_berg(i,j+1)*G%areaT(i,j+1))) / &
(G%areaT(i,j) + G%areaT(i,j+1))
forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * &
min(forces%mass_berg(i,j), forces%mass_berg(i,j+1))
From 5398e6fdfe34cf7048bb0296eccb2ad81edfaf2b Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 07:34:09 -0500
Subject: [PATCH 12/30] (*)Parenthesize CoriolisStokes and LA_Stk for FMAs
Added parentheses to the calculation of the Stokes-drift Coriolis velocity
increments in CoriolisStokes so that it will be rotationally invariant when
fused-multiply-adds are enabled. All answers are bitwise identical because
CoriolisStokes is still under development and is never called, with a fatal
error occurring if anyone tries to use it. Also added parentheses to two
expressions calculating the magnitude of the Stokes velocity in
get_Langmuir_Number. Answers could change for some cases that use Langmuir
turbulence parameterizations with FMAs enabled.
---
src/user/MOM_wave_interface.F90 | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90
index 656ff5b569..08484da1f8 100644
--- a/src/user/MOM_wave_interface.F90
+++ b/src/user/MOM_wave_interface.F90
@@ -1216,7 +1216,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, &
enddo
call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx)
call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy)
- LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY)
+ LA_STK = sqrt((LA_STKX*LA_STKX) + (LA_STKY*LA_STKY))
elseif (Waves%WaveMethod==SURFBANDS) then
allocate(StkBand_X(Waves%NumBands), StkBand_Y(Waves%NumBands))
do bb = 1,Waves%NumBands
@@ -1225,7 +1225,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, &
enddo
call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_X, LA_STKx )
call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_Y, LA_STKy )
- LA_STK = sqrt(LA_STKX**2 + LA_STKY**2)
+ LA_STK = sqrt((LA_STKX**2) + (LA_STKY**2))
deallocate(StkBand_X, StkBand_Y)
elseif (Waves%WaveMethod==DHH85) then
! Temporarily integrating profile rather than spectrum for simplicity
@@ -1235,7 +1235,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, &
enddo
call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx)
call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy)
- LA_STK = sqrt(LA_STKX**2 + LA_STKY**2)
+ LA_STK = sqrt((LA_STKX**2) + (LA_STKY**2))
elseif (Waves%WaveMethod==LF17) then
call get_StokesSL_LiFoxKemper(ustar, HBL*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA)
elseif (Waves%WaveMethod==Null_WaveMethod) then
@@ -1655,8 +1655,8 @@ subroutine CoriolisStokes(G, GV, dt, h, u, v, Waves)
do k = 1, GV%ke
do j = G%jsc, G%jec
do I = G%iscB, G%iecB
- DVel = 0.25*(Waves%us_y(i,j+1,k)+Waves%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + &
- 0.25*(Waves%us_y(i,j,k)+Waves%us_y(i-1,j,k))*G%CoriolisBu(i,j)
+ DVel = 0.25*((Waves%us_y(i,J+1,k)+Waves%us_y(i-1,J+1,k)) * G%CoriolisBu(I,J+1)) + &
+ 0.25*((Waves%us_y(i,J,k)+Waves%us_y(i-1,J,k)) * G%CoriolisBu(I,J))
u(I,j,k) = u(I,j,k) + DVEL*dt
enddo
enddo
@@ -1665,8 +1665,8 @@ subroutine CoriolisStokes(G, GV, dt, h, u, v, Waves)
do k = 1, GV%ke
do J = G%jscB, G%jecB
do i = G%isc, G%iec
- DVel = 0.25*(Waves%us_x(i+1,j,k)+Waves%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + &
- 0.25*(Waves%us_x(i,j,k)+Waves%us_x(i,j-1,k))*G%CoriolisBu(i,j)
+ DVel = 0.25*((Waves%us_x(I+1,j,k)+Waves%us_x(I+1,j-1,k)) * G%CoriolisBu(I+1,J)) + &
+ 0.25*((Waves%us_x(I,j,k)+Waves%us_x(I,j-1,k)) * G%CoriolisBu(I,J))
v(i,J,k) = v(i,j,k) - DVEL*dt
enddo
enddo
From 56d053a048bc574722faaa93d8a629db73d7d6a1 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 08:46:11 -0500
Subject: [PATCH 13/30] +(*)Add and use G%Coriolis2Bu
Added the new element Coriolis2Bu to the ocean_grid_type and the
dyn_horgrid_type to hold the square of the Coriolis parameter, and use this
array in 10 routines (including btstep, set_dtbt, calculate_diagnostic_fields,
VarMix_init, propagate_int_tide, Calculate_kappa_shear, Calc_kappa_shear_vertex
and add_MLrad_diffusivity) that had been calculating and averaging the square of
the Coriolis parameter. This could change some answers with FMAs enabled
because the compilers were previously free to split up some of the squares
when averaging the squared Coriolis parameter, but without FMAs all answers are
bitwise identical. This commit does add a new element to two transparent
types.
---
src/core/MOM_barotropic.F90 | 8 +++----
src/core/MOM_grid.F90 | 8 ++++---
src/core/MOM_transcribe_grid.F90 | 4 ++++
src/diagnostics/MOM_diagnostics.F90 | 8 +++----
src/framework/MOM_dyn_horgrid.F90 | 9 +++++---
.../MOM_fixed_initialization.F90 | 13 ++++++++---
.../lateral/MOM_internal_tides.F90 | 22 +++++++++----------
.../lateral/MOM_lateral_mixing_coeffs.F90 | 10 ++++-----
.../vertical/MOM_kappa_shear.F90 | 6 ++---
.../vertical/MOM_set_diffusivity.F90 | 4 ++--
10 files changed, 54 insertions(+), 38 deletions(-)
diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90
index 83bfab0820..f3d01bd886 100644
--- a/src/core/MOM_barotropic.F90
+++ b/src/core/MOM_barotropic.F90
@@ -1649,8 +1649,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j))) + &
(gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + &
gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + &
- ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 )
+ ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j))**2 + (G%IdyT(i,j))**2), &
G%IareaT(i,j) * &
((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + &
@@ -2906,8 +2906,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add)
Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * &
((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + &
(gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + &
- ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 )
+ ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2
enddo ; enddo
dtbt_max = sqrt(min_max_dt2 / dgeo_de)
diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90
index 52e37f1a9b..6fb8426395 100644
--- a/src/core/MOM_grid.F90
+++ b/src/core/MOM_grid.F90
@@ -171,7 +171,8 @@ module MOM_grid
Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m].
Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m].
real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: &
- CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1].
+ CoriolisBu, & !< The Coriolis parameter at corner points [T-1 ~> s-1].
+ Coriolis2Bu !< The square of the Coriolis parameter at corner points [T-2 ~> s-2].
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1].
df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1].
@@ -581,6 +582,7 @@ subroutine allocate_metrics(G)
ALLOC_(G%bathyT(isd:ied, jsd:jed)) ; G%bathyT(:,:) = -G%Z_ref
ALLOC_(G%CoriolisBu(IsdB:IedB, JsdB:JedB)) ; G%CoriolisBu(:,:) = 0.0
+ ALLOC_(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB)) ; G%Coriolis2Bu(:,:) = 0.0
ALLOC_(G%dF_dx(isd:ied, jsd:jed)) ; G%dF_dx(:,:) = 0.0
ALLOC_(G%dF_dy(isd:ied, jsd:jed)) ; G%dF_dy(:,:) = 0.0
@@ -626,8 +628,8 @@ subroutine MOM_grid_end(G)
DEALLOC_(G%dx_Cv) ; DEALLOC_(G%dy_Cu)
- DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu)
- DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy)
+ DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu) ; DEALLOC_(G%Coriolis2Bu)
+ DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy)
DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot)
DEALLOC_(G%porous_DminU) ; DEALLOC_(G%porous_DmaxU) ; DEALLOC_(G%porous_DavgU)
diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90
index b8e213fa62..f8ae58d9e1 100644
--- a/src/core/MOM_transcribe_grid.F90
+++ b/src/core/MOM_transcribe_grid.F90
@@ -105,6 +105,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US)
oG%dyBu(I,J) = dG%dyBu(I+ido,J+jdo)
oG%areaBu(I,J) = dG%areaBu(I+ido,J+jdo)
oG%CoriolisBu(I,J) = dG%CoriolisBu(I+ido,J+jdo)
+ oG%Coriolis2Bu(I,J) = dG%Coriolis2Bu(I+ido,J+jdo)
oG%mask2dBu(I,J) = dG%mask2dBu(I+ido,J+jdo)
enddo ; enddo
@@ -165,6 +166,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US)
call pass_var(oG%geoLatBu, oG%Domain, position=CORNER)
call pass_vector(oG%dxBu, oG%dyBu, oG%Domain, To_All+Scalar_Pair, BGRID_NE)
call pass_var(oG%CoriolisBu, oG%Domain, position=CORNER)
+ call pass_var(oG%Coriolis2Bu, oG%Domain, position=CORNER)
call pass_var(oG%mask2dBu, oG%Domain, position=CORNER)
if (oG%bathymetry_at_vel) then
@@ -263,6 +265,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US)
dG%dyBu(I,J) = oG%dyBu(I+ido,J+jdo)
dG%areaBu(I,J) = oG%areaBu(I+ido,J+jdo)
dG%CoriolisBu(I,J) = oG%CoriolisBu(I+ido,J+jdo)
+ dG%Coriolis2Bu(I,J) = oG%Coriolis2Bu(I+ido,J+jdo)
dG%mask2dBu(I,J) = oG%mask2dBu(I+ido,J+jdo)
enddo ; enddo
@@ -324,6 +327,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US)
call pass_var(dG%geoLatBu, dG%Domain, position=CORNER)
call pass_vector(dG%dxBu, dG%dyBu, dG%Domain, To_All+Scalar_Pair, BGRID_NE)
call pass_var(dG%CoriolisBu, dG%Domain, position=CORNER)
+ call pass_var(dG%Coriolis2Bu, dG%Domain, position=CORNER)
call pass_var(dG%mask2dBu, dG%Domain, position=CORNER)
if (dG%bathymetry_at_vel) then
diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90
index fd8057c38f..26af9f67d5 100644
--- a/src/diagnostics/MOM_diagnostics.F90
+++ b/src/diagnostics/MOM_diagnostics.F90
@@ -679,8 +679,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
do j=js,je ; do i=is,ie
! Blend the equatorial deformation radius with the standard one.
f2_h = absurdly_small_freq2 + 0.25 * &
- ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))
+ ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
mag_beta = sqrt(0.5 * ( &
(((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
@@ -729,8 +729,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
do j=js,je ; do i=is,ie
! Blend the equatorial deformation radius with the standard one.
f2_h = absurdly_small_freq2 + 0.25 * &
- ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))
+ ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
mag_beta = sqrt(0.5 * ( &
(((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90
index b973b08d4b..987d5bf502 100644
--- a/src/framework/MOM_dyn_horgrid.F90
+++ b/src/framework/MOM_dyn_horgrid.F90
@@ -169,7 +169,8 @@ module MOM_dyn_horgrid
Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m].
Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m].
real, allocatable, dimension(:,:) :: &
- CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1].
+ CoriolisBu, & !< The Coriolis parameter at corner points [T-1 ~> s-1].
+ Coriolis2Bu !< The square of the Coriolis parameter at corner points [T-2 ~> s-2].
real, allocatable, dimension(:,:) :: &
df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1].
df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1].
@@ -289,6 +290,7 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel)
allocate(G%bathyT(isd:ied, jsd:jed), source=0.0)
allocate(G%CoriolisBu(IsdB:IedB, JsdB:JedB), source=0.0)
+ allocate(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB), source=0.0)
allocate(G%dF_dx(isd:ied, jsd:jed), source=0.0)
allocate(G%dF_dy(isd:ied, jsd:jed), source=0.0)
@@ -360,6 +362,7 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns)
call rotate_array_pair(G_in%dxBu, G_in%dyBu, turns, G%dxBu, G%dyBu)
call rotate_array(G_in%areaBu, turns, G%areaBu)
call rotate_array(G_in%CoriolisBu, turns, G%CoriolisBu)
+ call rotate_array(G_in%Coriolis2Bu, turns, G%Coriolis2Bu)
call rotate_array(G_in%mask2dBu, turns, G%mask2dBu)
! Topography at the cell faces
@@ -528,8 +531,8 @@ subroutine destroy_dyn_horgrid(G)
deallocate(G%porous_DminU) ; deallocate(G%porous_DmaxU) ; deallocate(G%porous_DavgU)
deallocate(G%porous_DminV) ; deallocate(G%porous_DmaxV) ; deallocate(G%porous_DavgV)
- deallocate(G%bathyT) ; deallocate(G%CoriolisBu)
- deallocate(G%dF_dx) ; deallocate(G%dF_dy)
+ deallocate(G%bathyT) ; deallocate(G%CoriolisBu) ; deallocate(G%Coriolis2Bu)
+ deallocate(G%dF_dx) ; deallocate(G%dF_dy)
deallocate(G%sin_rot) ; deallocate(G%cos_rot)
if (allocated(G%Dblock_u)) deallocate(G%Dblock_u)
diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90
index 322abc6d5e..8b172eacb9 100644
--- a/src/initialization/MOM_fixed_initialization.F90
+++ b/src/initialization/MOM_fixed_initialization.F90
@@ -60,14 +60,15 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
logical, intent(in) :: write_geom !< If true, write grid geometry files.
character(len=*), intent(in) :: output_dir !< The directory into which to write files.
- ! Local
+ ! Local variables
character(len=200) :: inputdir ! The directory where NetCDF input files are.
character(len=200) :: config
logical :: read_porous_file
character(len=40) :: mdl = "MOM_fixed_initialization" ! This module's name.
+ integer :: I, J
logical :: debug
-! This include declares and sets the variable "version".
-#include "version_variable.h"
+ ! This include declares and sets the variable "version".
+# include "version_variable.h"
call callTree_enter("MOM_initialize_fixed(), MOM_fixed_initialization.F90")
call log_version(PF, mdl, version, "")
@@ -156,8 +157,14 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
call MOM_initialize_rotation(G%CoriolisBu, G, PF, US=US)
! Calculate the components of grad f (beta)
call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US)
+! Calculate the square of the Coriolis parameter
+ do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB
+ G%Coriolis2Bu(I,J) = G%CoriolisBu(I,J)**2
+ enddo ; enddo
+
if (debug) then
call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T)
+ call qchksum(G%Coriolis2Bu, "MOM_initialize_fixed: f2 ", G%HI, scale=US%s_to_T**2)
call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%m_to_L*US%s_to_T)
call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%m_to_L*US%s_to_T)
endif
diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90
index 5b9ce4934c..79eb31f243 100644
--- a/src/parameterizations/lateral/MOM_internal_tides.F90
+++ b/src/parameterizations/lateral/MOM_internal_tides.F90
@@ -361,8 +361,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C
if (CS%energized_angle <= 0) then
frac_per_sector = 1.0 / real(CS%nAngle)
do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie
- f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))
+ f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
if (CS%frequency(fr)**2 > f2) &
CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * &
CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)
@@ -371,8 +371,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C
frac_per_sector = 1.0
a = CS%energized_angle
do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie
- f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))
+ f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
if (CS%frequency(fr)**2 > f2) &
CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * &
CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)
@@ -630,8 +630,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C
do j=js,je ; do i=is,ie
id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging
! Calculate horizontal phase velocity magnitudes
- f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))
+ f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2)
c_phase = 0.0
if (Kmag2 > 0.0) then
@@ -1134,8 +1134,8 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang)
! Do the refraction.
do i=is,ie
- f2 = 0.25* ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2))
+ f2 = 0.25* ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J)))
favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + &
(G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J)))
df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - &
@@ -1355,7 +1355,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss)
! Fix indexing here later
speed(:,:) = 0.0
do J=jsh-1,jeh ; do I=ish-1,ieh
- f2 = G%CoriolisBu(I,J)**2
+ f2 = G%Coriolis2Bu(I,J)
speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * &
sqrt(max(freq2 - f2, 0.0)) * Ifreq
enddo ; enddo
@@ -1385,12 +1385,12 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss)
enddo
do j=jsh,jeh ; do I=ish-1,ieh
- f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2)
+ f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1))
speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * &
sqrt(max(freq2 - f2, 0.0)) * Ifreq
enddo ; enddo
do J=jsh-1,jeh ; do i=ish,ieh
- f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2)
+ f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J))
speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * &
sqrt(max(freq2 - f2, 0.0)) * Ifreq
enddo ; enddo
diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
index defbd78aa7..55e448ec90 100644
--- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
+++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
@@ -1516,7 +1516,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
do J=js-1,Jeq ; do I=is-1,Ieq
CS%f2_dx2_q(I,J) = (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * &
- max(G%CoriolisBu(I,J)**2, absurdly_small_freq**2)
+ max(G%Coriolis2Bu(I,J), absurdly_small_freq**2)
CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J))**2 + (G%dyBu(I,J))**2) * (sqrt(0.5 * &
( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + &
@@ -1526,7 +1526,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
do j=js,je ; do I=is-1,Ieq
CS%f2_dx2_u(I,j) = (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * &
- max(0.5* (G%CoriolisBu(I,J)**2+G%CoriolisBu(I,J-1)**2), absurdly_small_freq**2)
+ max(0.5* (G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I,J-1)), absurdly_small_freq**2)
CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j))**2 + (G%dyCu(I,j))**2) * (sqrt( &
0.25*( (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2 + &
((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + &
@@ -1537,7 +1537,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
do J=js-1,Jeq ; do i=is,ie
CS%f2_dx2_v(i,J) = ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * &
- max(0.5*(G%CoriolisBu(I,J)**2+G%CoriolisBu(I-1,J)**2), absurdly_small_freq**2)
+ max(0.5*(G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I-1,J)), absurdly_small_freq**2)
CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * (sqrt( &
((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
0.25*( (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
@@ -1572,8 +1572,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
allocate(CS%f2_dx2_h(isd:ied,jsd:jed), source=0.0)
do j=js-1,je+1 ; do i=is-1,ie+1
CS%f2_dx2_h(i,j) = (G%dxT(i,j)**2 + G%dyT(i,j)**2) * &
- max(0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)), &
+ max(0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))), &
absurdly_small_freq**2)
CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j))**2 + (G%dyT(i,j))**2) * (sqrt(0.5 * &
( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90
index 8a1974d8ea..d44ab79d1b 100644
--- a/src/parameterizations/vertical/MOM_kappa_shear.F90
+++ b/src/parameterizations/vertical/MOM_kappa_shear.F90
@@ -279,8 +279,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, &
do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo
endif
- f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2))
+ f2 = 0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J)))
surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j)
! ---------------------------------------------------- I_Ld2_1d, dz_Int_1d
@@ -551,7 +551,7 @@ 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
+ f2 = G%Coriolis2Bu(I,J)
surface_pres = 0.0
if (associated(p_surf)) then
if (CS%psurf_bug) then
diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90
index ef2e4ed5f6..85c70efcfa 100644
--- a/src/parameterizations/vertical/MOM_set_diffusivity.F90
+++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90
@@ -1631,8 +1631,8 @@ subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_t
if (CS%ML_omega_frac >= 1.0) then
f_sq = 4.0 * Omega2
else
- f_sq = 0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + &
- (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2))
+ f_sq = 0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J)))
if (CS%ML_omega_frac > 0.0) &
f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq
endif
From 49419f7327b58ea3e93b54133072292e3a8a43f7 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:34:14 -0500
Subject: [PATCH 14/30] (*)Parenthesize thickness_diffuse for FMAs
Added parentheses to 17 expressions in thickness_diffuse_full,
thickness_diffuse and thickness_diffuse_init to give rotationally consistent
solutions when fused-multiply-adds are enabled. One comment was also added to
note that the calculation of PE_release_h is does not exhibit rotational
symmetry when MEKE_GM_SRC_ALT is set to true. All answers are bitwise identical
in cases without FMAs, but answers could change when FMAs are enabled.
---
.../lateral/MOM_thickness_diffuse.F90 | 61 ++++++++++---------
1 file changed, 31 insertions(+), 30 deletions(-)
diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90
index 178e6f76e2..d42d9600ce 100644
--- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90
+++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90
@@ -218,12 +218,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp
!$OMP parallel do default(shared)
do j=js,je ; do I=is-1,ie
KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / &
- (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j)))
+ (dt * ((G%IdxCu(I,j)*G%IdxCu(I,j)) + (G%IdyCu(I,j)*G%IdyCu(I,j))))
enddo ; enddo
!$OMP parallel do default(shared)
do j=js-1,je ; do I=is,ie
KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / &
- (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J)))
+ (dt * ((G%IdxCv(i,J)*G%IdxCv(i,J)) + (G%IdyCv(i,J)*G%IdyCv(i,J))))
enddo ; enddo
! Calculates interface heights, e, in [Z ~> m].
@@ -535,8 +535,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp
enddo ; enddo
! diagnose diffusivity at T-points
do j=js,je ; do i=is,ie
- Kh_t(i,j,k) = ((hu(I-1,j)*KH_u_lay(i-1,j) + hu(I,j)*KH_u_lay(I,j)) + &
- (hv(i,J-1)*KH_v_lay(i,J-1) + hv(i,J)*KH_v_lay(i,J))) / &
+ Kh_t(i,j,k) = (((hu(I-1,j)*KH_u_lay(i-1,j)) + (hu(I,j)*KH_u_lay(I,j))) + &
+ ((hv(i,J-1)*KH_v_lay(i,J-1)) + (hv(i,J)*KH_v_lay(i,J)))) / &
((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + 1.0e-20)
! Use this denominator instead if hu and hv are actual thicknesses rather than a 0/1 mask:
! ((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + h_neglect)
@@ -916,9 +916,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
drho_dS_u(I) * (S(i,j,k)-S(i,j,k-1)))
drdkR = (drho_dT_u(I) * (T(i+1,j,k)-T(i+1,j,k-1)) + &
drho_dS_u(I) * (S(i+1,j,k)-S(i+1,j,k-1)))
- drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K)
+ drdkDe_u(I,K) = (drdkR * e(i+1,j,K)) - (drdkL * e(i,j,K))
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)
+ 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
@@ -950,7 +950,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
! These unnormalized weights have been rearranged to minimize divisions.
wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL)
- drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR)
+ drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR))
! The expression for drdz above is mathematically equivalent to:
! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / &
! ((hg2L/haL) + (hg2R/haR))
@@ -963,7 +963,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
N2_unlim = drdz*G_rho0
else
N2_unlim = (GV%g_Earth*GV%RZ_to_H) * &
- ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR))
+ (((wtL * drdkL) + (wtR * drdkR)) / ((haL*wtL) + (haR*wtR)))
endif
dzg2A = dz(i,j,k-1)*dz(i+1,j,k-1) + dz_neglect2
@@ -1082,10 +1082,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then
Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / &
- ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + &
- ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) )
+ ( (((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k)) + ((h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1))) + &
+ (((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k)) + ((h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1))) )
! Use an average density to convert the volume streamfunction estimate into a mass streamfunction.
- Z_to_H = (GV%RZ_to_H*Rho_avg)
+ Z_to_H = GV%RZ_to_H*Rho_avg
else
Z_to_H = GV%Z_to_H
endif
@@ -1235,9 +1235,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
drho_dS_v(i) * (S(i,j,k)-S(i,j,k-1)))
drdkR = (drho_dT_v(i) * (T(i,j+1,k)-T(i,j+1,k-1)) + &
drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1)))
- drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K)
+ drdkDe_v(i,K) = (drdkR * e(i,j+1,K)) - (drdkL * e(i,j,K))
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)
+ 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
@@ -1271,7 +1271,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
! These unnormalized weights have been rearranged to minimize divisions.
wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL)
- drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR)
+ drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR))
! The expression for drdz above is mathematically equivalent to:
! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / &
! ((hg2L/haL) + (hg2R/haR))
@@ -1284,7 +1284,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
N2_unlim = drdz*G_rho0
else
N2_unlim = (GV%g_Earth*GV%RZ_to_H) * &
- ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR))
+ (((wtL * drdkL) + (wtR * drdkR)) / ((haL*wtL) + (haR*wtR)))
endif
dzg2A = dz(i,j,k-1)*dz(i,j+1,k-1) + dz_neglect2
@@ -1401,10 +1401,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
do i=is,ie
if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then
Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / &
- ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + &
- ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) )
+ ( (((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k)) + ((h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1))) + &
+ (((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k)) + ((h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1))) )
! Use an average density to convert the volume streamfunction estimate into a mass streamfunction.
- Z_to_H = (GV%RZ_to_H*Rho_avg)
+ Z_to_H = GV%RZ_to_H*Rho_avg
else
Z_to_H = GV%Z_to_H
endif
@@ -1510,7 +1510,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1))
if (allocated(tv%SpV_avg)) then
G_scale = GV%H_to_RZ * GV%g_Earth * &
- ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) / &
+ ( ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1)) + ((h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) ) / &
( (h(i,j,1) + h(i+1,j,1)) + 2.0*hn_2 ) )
endif
endif
@@ -1547,7 +1547,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1))
if (allocated(tv%SpV_avg)) then
G_scale = GV%H_to_RZ * GV%g_Earth * &
- ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) / &
+ ( ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1)) + ((h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) ) / &
( (h(i,j,1) + h(i,j+1,1)) + 2.0*hn_2 ) )
endif
endif
@@ -1572,22 +1572,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
if (CS%MEKE_src_answer_date >= 20240601) then
do j=js,je ; do i=is,ie ; do k=nz,1,-1
PE_release_h = -0.25 * GV%H_to_RZ * &
- ( (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + &
- Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k)) + &
- (Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + &
- Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) )
+ ( ((KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k)) + &
+ (Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k))) + &
+ ((Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k)) + &
+ (Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k))) )
MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h
enddo ; enddo ; enddo
else
do j=js,je ; do i=is,ie ; do k=nz,1,-1
PE_release_h = -0.25 * GV%H_to_RZ * &
- (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + &
- Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + &
- Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + &
- Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k))
+ ((KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k)) + &
+ (Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k)) + &
+ (Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k)) + &
+ (Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)))
MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h
enddo ; enddo ; enddo
endif
+
if (CS%debug) then
call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2)
call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, scale=US%L_to_m**2*US%s_to_T, &
@@ -2198,11 +2199,11 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS)
allocate(CS%Kh_eta_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.)
allocate(CS%Kh_eta_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.)
do j=G%jsc,G%jec ; do I=G%isc-1,G%iec
- grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / (G%dxCu(I,j)**2 + G%dyCu(I,j)**2))
+ grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2)))
CS%Kh_eta_u(I,j) = G%OBCmaskCu(I,j) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp)
enddo ; enddo
do J=G%jsc-1,G%jec ; do i=G%isc,G%iec
- grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / (G%dxCv(i,J)**2 + G%dyCv(i,J)**2))
+ grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2)))
CS%Kh_eta_v(i,J) = G%OBCmaskCv(i,J) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp)
enddo ; enddo
endif
From 03dc6f9a5b2d24ecc4011cd5ac8319ad0b014c05 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:34:41 -0500
Subject: [PATCH 15/30] (*)Parenthesize Zanna_Bolton for FMAs
Added parentheses to 2 expressions in the Zanna_Bolton code and rearranged
another line so that the u- and v-discretizations introduce terms in the same
order so that the Zanna_Bolton code will exhibit rotationally consistent
solutions when fused-multiply-adds are enabled. All answers are bitwise
identical in cases without FMAs, but answers could change with FMAs enabled in
cases that use the Zanna-Bolton parameterization.
---
.../lateral/MOM_Zanna_Bolton.F90 | 36 +++++++++----------
1 file changed, 16 insertions(+), 20 deletions(-)
diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
index f472118e7d..db3542764d 100644
--- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
+++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
@@ -484,9 +484,9 @@ subroutine compute_c_diss(G, GV, CS)
if (CS%Klower_shear == 0) then
do j=js-1,je+1 ; do i=is-1,ie+1
shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( &
- (CS%sh_xy(I-1,J-1,k)**2 + CS%sh_xy(I,J ,k)**2) &
- + (CS%sh_xy(I-1,J ,k)**2 + CS%sh_xy(I,J-1,k)**2) &
- ))
+ ((CS%sh_xy(I-1,J-1,k)**2) + (CS%sh_xy(I,J ,k)**2)) &
+ + ((CS%sh_xy(I-1,J ,k)**2) + (CS%sh_xy(I,J-1,k)**2)) &
+ ))
CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j))
enddo; enddo
@@ -494,11 +494,11 @@ subroutine compute_c_diss(G, GV, CS)
elseif (CS%Klower_shear == 1) then
do j=js-1,je+1 ; do i=is-1,ie+1
shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( &
- ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) &
- + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) &
- + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) &
- + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) &
- ))
+ ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) &
+ + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) &
+ + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) &
+ + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) &
+ ))
CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j))
enddo; enddo
endif
@@ -583,10 +583,10 @@ subroutine compute_stress(G, GV, CS)
if (vort_sh_scheme_1) then
! It is assumed that B.C. is applied to sh_xy and vort_xy
vort_sh = 0.25 * ( &
- ((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k) + &
- (G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k)) + &
- ((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k) + &
- (G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k)) &
+ (((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k)) + &
+ ((G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k))) + &
+ (((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k)) + &
+ ((G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k))) &
) * G%IareaT(i,j)
endif
@@ -717,10 +717,8 @@ subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy
! but here is the discretization of div(S)
do j=js,je ; do I=Isq,Ieq
h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect
- fx = -((G%IdyCu(I,j)*(Mxx(i,j) - &
- Mxx(i+1,j)) + &
- G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - &
- dx2q(I,J) *Mxy(I,J))) * &
+ fx = -((G%IdyCu(I,j)*(Mxx(i,j) - Mxx(i+1,j)) + &
+ G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - dx2q(I,J)*Mxy(I,J))) * &
G%IareaCu(I,j)) / h_u
diffu(I,j,k) = diffu(I,j,k) + fx
if (save_ZB2020u) &
@@ -730,10 +728,8 @@ subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy
! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90)
do J=Jsq,Jeq ; do i=is,ie
h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect
- fy = -((G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - &
- dy2q(I,J) *Mxy(I,J)) + & ! NOTE this plus
- G%IdxCv(i,J)*(Myy(i,j) - &
- Myy(i,j+1))) * &
+ fy = -((G%IdxCv(i,J)*(Myy(i,j) - Myy(i,j+1)) + &
+ G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - dy2q(I,J)*Mxy(I,J))) * &
G%IareaCv(i,J)) / h_v
diffv(i,J,k) = diffv(i,J,k) + fy
if (save_ZB2020v) &
From 654cd4aab7e8ff267568878de7c2e4fada0cf798 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:35:01 -0500
Subject: [PATCH 16/30] (*)Parenthesize MOM_internal_tides for FMAs
Added parentheses to 19 expressions in the MOM_internal_tides propagation code
to exhibit rotationally consistent solutions when fused-multiply-adds are
enabled. All answers are bitwise identical in cases without FMAs, but answers
could change when FMAs are enabled in models that use the ray-tracing based
internal tides code.
---
.../lateral/MOM_internal_tides.F90 | 48 +++++++++----------
1 file changed, 24 insertions(+), 24 deletions(-)
diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90
index 79eb31f243..b1e84a74f7 100644
--- a/src/parameterizations/lateral/MOM_internal_tides.F90
+++ b/src/parameterizations/lateral/MOM_internal_tides.F90
@@ -1580,28 +1580,28 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS
!a3 = (yW - yNW)*(0.5*(xW + xNW))
!a4 = (yNW - yN)*(0.5*(xNW + xN))
!aW = a1 + a2 + a3 + a4
- aW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW))
+ aW = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW)))
! southwest area
!a1 = (yCrn - yS)*(0.5*(xCrn + xS))
!a2 = (yS - ySW)*(0.5*(xS + xSW))
!a3 = (ySW - yW)*(0.5*(xSW + xW))
!a4 = (yW - yCrn)*(0.5*(xW + xCrn))
!aSW = a1 + a2 + a3 + a4
- aSW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS))
+ aSW = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS)))
! south area
!a1 = (yE - ySE)*(0.5*(xE + xSE))
!a2 = (ySE - yS)*(0.5*(xSE + xS))
!a3 = (yS - yCrn)*(0.5*(xS + xCrn))
!a4 = (yCrn - yE)*(0.5*(xCrn + xE))
!aS = a1 + a2 + a3 + a4
- aS = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE))
+ aS = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE)))
! area within cell
!a1 = (yNE - yE)*(0.5*(xNE + xE))
!a2 = (yE - yCrn)*(0.5*(xE + xCrn))
!a3 = (yCrn - yN)*(0.5*(xCrn + xN))
!a4 = (yN - yNE)*(0.5*(xN + xNE))
!aC = a1 + a2 + a3 + a4
- aC = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN))
+ aC = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN)))
elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then
xCrn = x(I,J-1); yCrn = y(I,J-1)
! south area
@@ -1610,28 +1610,28 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS
!a3 = (ySW - yW)*(0.5*(xSW + xW))
!a4 = (yW - yCrn)*(0.5*(xW + xCrn))
!aS = a1 + a2 + a3 + a4
- aS = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS))
+ aS = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS)))
! southeast area
!a1 = (yE - ySE)*(0.5*(xE + xSE))
!a2 = (ySE - yS)*(0.5*(xSE + xS))
!a3 = (yS - yCrn)*(0.5*(xS + xCrn))
!a4 = (yCrn - yE)*(0.5*(xCrn + xE))
!aSE = a1 + a2 + a3 + a4
- aSE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE))
+ aSE = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE)))
! east area
!a1 = (yNE - yE)*(0.5*(xNE + xE))
!a2 = (yE - yCrn)*(0.5*(xE + xCrn))
!a3 = (yCrn - yN)*(0.5*(xCrn + xN))
!a4 = (yN - yNE)*(0.5*(xN + xNE))
!aE = a1 + a2 + a3 + a4
- aE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN))
+ aE = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN)))
! area within cell
!a1 = (yN - yCrn)*(0.5*(xN + xCrn))
!a2 = (yCrn - yW)*(0.5*(xCrn + xW))
!a3 = (yW - yNW)*(0.5*(xW + xNW))
!a4 = (yNW - yN)*(0.5*(xNW + xN))
!aC = a1 + a2 + a3 + a4
- aC = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW))
+ aC = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW)))
elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then
xCrn = x(I,J); yCrn = y(I,J)
! east area
@@ -1640,28 +1640,28 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS
!a3 = (yS - yCrn)*(0.5*(xS + xCrn))
!a4 = (yCrn - yE)*(0.5*(xCrn + xE))
!aE = a1 + a2 + a3 + a4
- aE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE))
+ aE = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE)))
! northeast area
!a1 = (yNE - yE)*(0.5*(xNE + xE))
!a2 = (yE - yCrn)*(0.5*(xE + xCrn))
!a3 = (yCrn - yN)*(0.5*(xCrn + xN))
!a4 = (yN - yNE)*(0.5*(xN + xNE))
!aNE = a1 + a2 + a3 + a4
- aNE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN))
+ aNE = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN)))
! north area
!a1 = (yN - yCrn)*(0.5*(xN + xCrn))
!a2 = (yCrn - yW)*(0.5*(xCrn + xW))
!a3 = (yW - yNW)*(0.5*(xW + xNW))
!a4 = (yNW - yN)*(0.5*(xNW + xN))
!aN = a1 + a2 + a3 + a4
- aN = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW))
+ aN = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW)))
! area within cell
!a1 = (yCrn - yS)*(0.5*(xCrn + xS))
!a2 = (yS - ySW)*(0.5*(xS + xSW))
!a3 = (ySW - yW)*(0.5*(xSW + xW))
!a4 = (yW - yCrn)*(0.5*(xW + xCrn))
!aC = a1 + a2 + a3 + a4
- aC = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS))
+ aC = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS)))
elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then
xCrn = x(I-1,J); yCrn = y(I-1,J)
! north area
@@ -1670,37 +1670,37 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS
!a3 = (yCrn - yN)*(0.5*(xCrn + xN))
!a4 = (yN - yNE)*(0.5*(xN + xNE))
!aN = a1 + a2 + a3 + a4
- aN = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN))
+ aN = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN)))
! northwest area
!a1 = (yN - yCrn)*(0.5*(xN + xCrn))
!a2 = (yCrn - yW)*(0.5*(xCrn + xW))
!a3 = (yW - yNW)*(0.5*(xW + xNW))
!a4 = (yNW - yN)*(0.5*(xNW + xN))
!aNW = a1 + a2 + a3 + a4
- aNW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW))
+ aNW = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW)))
! west area
!a1 = (yCrn - yS)*(0.5*(xCrn + xS))
!a2 = (yS - ySW)*(0.5*(xS + xSW))
!a3 = (ySW - yW)*(0.5*(xSW + xW))
!a4 = (yW - yCrn)*(0.5*(xW + xCrn))
!aW = a1 + a2 + a3 + a4
- aW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS))
+ aW = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS)))
! area within cell
!a1 = (yE - ySE)*(0.5*(xE + xSE))
!a2 = (ySE - yS)*(0.5*(xSE + xS))
!a3 = (yS - yCrn)*(0.5*(xS + xCrn))
!a4 = (yCrn - yE)*(0.5*(xCrn + xE))
!aC = a1 + a2 + a3 + a4
- aC = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE))
+ aC = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE)))
endif
! energy weighting ----------------------------------------
a_total = (((aNE + aSW) + (aNW + aSE)) + ((aN + aS) + (aW + aE))) + aC
- E_new(m) = ( ( ( ( aNE*En(i+1,j+1) + aSW*En(i-1,j-1) ) + &
- ( aNW*En(i-1,j+1) + aSE*En(i+1,j-1) ) ) + &
- ( ( aN*En(i,j+1) + aS*En(i,j-1) ) + &
- ( aW*En(i-1,j) + aE*En(i+1,j) ) ) ) + &
+ E_new(m) = ( ( ( ( (aNE*En(i+1,j+1)) + (aSW*En(i-1,j-1)) ) + &
+ ( (aNW*En(i-1,j+1)) + (aSE*En(i+1,j-1)) ) ) + &
+ ( ( (aN*En(i,j+1)) + (aS*En(i,j-1)) ) + &
+ ( (aW*En(i-1,j)) + (aE*En(i+1,j)) ) ) ) + &
aC*En(i,j) ) / ( dx(i,j)*dy(i,j) )
enddo ! m-loop
! update energy in cell
@@ -1767,8 +1767,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res
Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J]
residual_loss(i,j,a) = residual_loss(i,j,a) + &
- (abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j) + &
- abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))
+ ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + &
+ (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j)))
enddo ; enddo
enddo ! a-loop
@@ -1848,8 +1848,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res
Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J]
residual_loss(i,j,a) = residual_loss(i,j,a) + &
- (abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j) + &
- abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))
+ ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + &
+ (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j)))
!if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging
! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.)
From ebf02a97a964c47b5996ddac21c12612a1e2e906 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:35:40 -0500
Subject: [PATCH 17/30] (*)Parenthesize find_uv_at_h for FMAs
Added parentheses to 10 expressions in find_uv_at_h to exhibit rotationally
consistent solutions and treat the velocities at both edges of a tracer cell
equivalently when fused-multiply-adds are enabled. All answers are bitwise
identical in cases without FMAs, but answers could change when FMAs are enabled.
---
.../vertical/MOM_diabatic_aux.F90 | 20 +++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90
index aa31024b24..51e9b33d97 100644
--- a/src/parameterizations/vertical/MOM_diabatic_aux.F90
+++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90
@@ -574,17 +574,17 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix)
b_denom_1 = h(i,j,1) + h_neglect
b1(i) = 1.0 / (b_denom_1 + eb(i,j,1))
d1(i) = b_denom_1 * b1(i)
- u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1))
- v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1))
+ u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1)))
+ v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1)))
enddo
do k=2,nz ; do i=is,ie
c1(i,k) = eb(i,j,k-1) * b1(i)
b_denom_1 = h(i,j,k) + d1(i)*ea(i,j,k) + h_neglect
b1(i) = 1.0 / (b_denom_1 + eb(i,j,k))
d1(i) = b_denom_1 * b1(i)
- u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k)) + &
+ u_h(i,j,k) = (h(i,j,k) * ((a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k))) + &
ea(i,j,k)*u_h(i,j,k-1))*b1(i)
- v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k)) + &
+ v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k))) + &
ea(i,j,k)*v_h(i,j,k-1))*b1(i)
enddo ; enddo
do k=nz-1,1,-1 ; do i=is,ie
@@ -594,18 +594,18 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix)
elseif (zero_mixing) then
do i=is,ie
b1(i) = 1.0 / (h(i,j,1) + h_neglect)
- u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1))
- v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1))
+ u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1)))
+ v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1)))
enddo
do k=2,nz ; do i=is,ie
b1(i) = 1.0 / (h(i,j,k) + h_neglect)
- u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k))) * b1(i)
- v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k))) * b1(i)
+ u_h(i,j,k) = (h(i,j,k) * ((a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k)))) * b1(i)
+ v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k)))) * b1(i)
enddo ; enddo
else
do k=1,nz ; do i=is,ie
- u_h(i,j,k) = a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k)
- v_h(i,j,k) = a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k)
+ u_h(i,j,k) = (a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k))
+ v_h(i,j,k) = (a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k))
enddo ; enddo
endif
enddo
From c0bef189afb1b0c61d054ee66ebf444d525d05a3 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:36:40 -0500
Subject: [PATCH 18/30] (*)Parenthesize set_viscous_ML for FMAs
Added parentheses to 19 expressions in set_viscous_ML, set_u_at_v and
set_v_at_u to treat the velocities at both edges of a tracer cell equivalently
when fused-multiply-adds are enabled, and thereby to exhibit exhibit
rotationally consistent solutions. Also swapped the order of the u- and
v-components in the u-point calculation of Uh2 to mirror the order of the
corresponging v-point calculation for the same purpose. All answers are bitwise
identical in cases without FMAs, but answers could change when FMAs are enabled.
---
.../vertical/MOM_set_viscosity.F90 | 56 +++++++++----------
1 file changed, 28 insertions(+), 28 deletions(-)
diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90
index d1d333b5ce..7687d91e17 100644
--- a/src/parameterizations/vertical/MOM_set_viscosity.F90
+++ b/src/parameterizations/vertical/MOM_set_viscosity.F90
@@ -1840,8 +1840,8 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC)
hwt_tot = (hwt(0,-1) + hwt(1,0)) + (hwt(1,-1) + hwt(0,0))
set_v_at_u = 0.0
if (hwt_tot > 0.0) set_v_at_u = &
- ((hwt(0,0) * v(i,J,k) + hwt(1,-1) * v(i+1,J-1,k)) + &
- (hwt(1,0) * v(i+1,J,k) + hwt(0,-1) * v(i,J-1,k))) / hwt_tot
+ (((hwt(0,0) * v(i,J,k)) + (hwt(1,-1) * v(i+1,J-1,k))) + &
+ ((hwt(1,0) * v(i+1,J,k)) + (hwt(0,-1) * v(i,J-1,k)))) / hwt_tot
end function set_v_at_u
@@ -1885,8 +1885,8 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC)
hwt_tot = (hwt(-1,0) + hwt(0,1)) + (hwt(0,0) + hwt(-1,1))
set_u_at_v = 0.0
if (hwt_tot > 0.0) set_u_at_v = &
- ((hwt(0,0) * u(I,j,k) + hwt(-1,1) * u(I-1,j+1,k)) + &
- (hwt(-1,0) * u(I-1,j,k) + hwt(0,1) * u(I,j+1,k))) / hwt_tot
+ (((hwt(0,0) * u(I,j,k)) + (hwt(-1,1) * u(I-1,j+1,k))) + &
+ ((hwt(-1,0) * u(I-1,j,k)) + (hwt(0,1) * u(I,j+1,k)))) / hwt_tot
end function set_u_at_v
@@ -2154,8 +2154,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
if (associated(tv%p_surf)) press(I) = press(I) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i+1,j))
k2 = max(1,nkml)
I_2hlay = 1.0 / (h(i,j,k2) + h(i+1,j,k2) + h_neglect)
- T_EOS(I) = (h(i,j,k2)*tv%T(i,j,k2) + h(i+1,j,k2)*tv%T(i+1,j,k2)) * I_2hlay
- S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay
+ T_EOS(I) = ((h(i,j,k2)*tv%T(i,j,k2)) + (h(i+1,j,k2)*tv%T(i+1,j,k2))) * I_2hlay
+ S_EOS(I) = ((h(i,j,k2)*tv%S(i,j,k2)) + (h(i+1,j,k2)*tv%S(i+1,j,k2))) * I_2hlay
enddo
call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, &
(/Isq-G%IsdB+1,Ieq-G%IsdB+1/) )
@@ -2170,13 +2170,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
hlay = 0.5*(h(i,j,k) + h(i+1,j,k))
if (hlay > h_tiny) then ! Only consider non-vanished layers.
I_2hlay = 1.0 / (h(i,j,k) + h(i+1,j,k))
- v_at_u = 0.5 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + &
- h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))) * I_2hlay
- Uh2 = ((uhtot(I) - htot(I)*u(I,j,k))**2 + (vhtot(I) - htot(I)*v_at_u)**2)
+ v_at_u = 0.5 * ((h(i,j,k) * (v(i,J,k) + v(i,J-1,k))) + &
+ (h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k)))) * I_2hlay
+ Uh2 = (uhtot(I) - htot(I)*u(I,j,k))**2 + (vhtot(I) - htot(I)*v_at_u)**2
if (use_EOS) then
- T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) * I_2hlay
- S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) * I_2hlay
+ T_lay = ((h(i,j,k)*tv%T(i,j,k)) + (h(i+1,j,k)*tv%T(i+1,j,k))) * I_2hlay
+ S_lay = ((h(i,j,k)*tv%S(i,j,k)) + (h(i+1,j,k)*tv%S(i+1,j,k))) * I_2hlay
if (nonBous_ML) then
gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(I) * (Thtot(I) - T_lay*htot(I)) + &
dSpV_dS(I) * (Shtot(I) - S_lay*htot(I)))
@@ -2211,11 +2211,11 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
do I=Isq,Ieq ; if (do_i(I)) then
htot(I) = htot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k))
uhtot(I) = uhtot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * u(I,j,k)
- vhtot(I) = vhtot(I) + 0.25 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + &
- h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k)))
+ vhtot(I) = vhtot(I) + 0.25 * ((h(i,j,k) * (v(i,J,k) + v(i,J-1,k))) + &
+ (h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))))
if (use_EOS) then
- Thtot(I) = Thtot(I) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k))
- Shtot(I) = Shtot(I) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k))
+ Thtot(I) = Thtot(I) + 0.5 * ((h(i,j,k)*tv%T(i,j,k)) + (h(i+1,j,k)*tv%T(i+1,j,k)))
+ Shtot(I) = Shtot(I) + 0.5 * ((h(i,j,k)*tv%S(i,j,k)) + (h(i+1,j,k)*tv%S(i+1,j,k)))
else
Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%Rlay(k)
endif
@@ -2379,8 +2379,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
! visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, &
! dztot(I) / (0.5 + sqrt(0.25 + &
- ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / &
- ! (ustar(i))**2 )) )
+ ! ((htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2) / &
+ ! (ustar(i)**2) )) )
ustar1 = ustar(i)
h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2
tbl_thick = max(CS%Htbl_shelf_min, &
@@ -2433,8 +2433,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
if (associated(tv%p_surf)) press(i) = press(i) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i,j+1))
k2 = max(1,nkml)
I_2hlay = 1.0 / (h(i,j,k2) + h(i,j+1,k2) + h_neglect)
- T_EOS(i) = (h(i,j,k2)*tv%T(i,j,k2) + h(i,j+1,k2)*tv%T(i,j+1,k2)) * I_2hlay
- S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay
+ T_EOS(i) = ((h(i,j,k2)*tv%T(i,j,k2)) + (h(i,j+1,k2)*tv%T(i,j+1,k2))) * I_2hlay
+ S_EOS(i) = ((h(i,j,k2)*tv%S(i,j,k2)) + (h(i,j+1,k2)*tv%S(i,j+1,k2))) * I_2hlay
enddo
call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, &
tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) )
@@ -2449,13 +2449,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
hlay = 0.5*(h(i,j,k) + h(i,j+1,k))
if (hlay > h_tiny) then ! Only consider non-vanished layers.
I_2hlay = 1.0 / (h(i,j,k) + h(i,j+1,k))
- u_at_v = 0.5 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + &
- h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))) * I_2hlay
- Uh2 = ((uhtot(I) - htot(I)*u_at_v)**2 + (vhtot(I) - htot(I)*v(i,J,k))**2)
+ u_at_v = 0.5 * ((h(i,j,k) * (u(I-1,j,k) + u(I,j,k))) + &
+ (h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k)))) * I_2hlay
+ Uh2 = (vhtot(i) - htot(i)*v(i,J,k))**2 + (uhtot(i) - htot(i)*u_at_v)**2
if (use_EOS) then
- T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) * I_2hlay
- S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) * I_2hlay
+ T_lay = ((h(i,j,k)*tv%T(i,j,k)) + (h(i,j+1,k)*tv%T(i,j+1,k))) * I_2hlay
+ S_lay = ((h(i,j,k)*tv%S(i,j,k)) + (h(i,j+1,k)*tv%S(i,j+1,k))) * I_2hlay
if (nonBous_ML) then
gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(i) * (Thtot(i) - T_lay*htot(i)) + &
dSpV_dS(i) * (Shtot(i) - S_lay*htot(i)))
@@ -2490,11 +2490,11 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
do i=is,ie ; if (do_i(i)) then
htot(i) = htot(i) + 0.5 * (h(i,J,k) + h(i,j+1,k))
vhtot(i) = vhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * v(i,J,k)
- uhtot(i) = uhtot(i) + 0.25 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + &
- h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k)))
+ uhtot(i) = uhtot(i) + 0.25 * ((h(i,j,k) * (u(I-1,j,k) + u(I,j,k))) + &
+ (h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))))
if (use_EOS) then
- Thtot(i) = Thtot(i) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k))
- Shtot(i) = Shtot(i) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k))
+ Thtot(i) = Thtot(i) + 0.5 * ((h(i,j,k)*tv%T(i,j,k)) + (h(i,j+1,k)*tv%T(i,j+1,k)))
+ Shtot(i) = Shtot(i) + 0.5 * ((h(i,j,k)*tv%S(i,j,k)) + (h(i,j+1,k)*tv%S(i,j+1,k)))
else
Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%Rlay(k)
endif
From 0b50a155aace08a159882ae7442c1499bbdc833d Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:45:21 -0500
Subject: [PATCH 19/30] (*)Rearrange calc_kappa_shear_vertex for FMAs
Added mathematically equivalent rearrangements of the code in
calc_kappa_shear_vertex that interpolates velocities, temperatures and
salinities to the vertices to expose the mask variables while ensuring that the
other multiplications occur within parentheses so that they will exhibit
rotational symmetry when fused-multiply-adds are enabled. FMAs can still occur,
but it will be multiplication by the 0-or-1 masks that are fused with an
addition. Also added parentheses to 3 expressions calculating the squared shear
in calculate_projected_state for rotational symmetry with FMAs. All answers are
bitwise identical in cases without FMAs, but answers could change when FMAs are
enabled.
---
.../vertical/MOM_kappa_shear.F90 | 34 +++++++++----------
1 file changed, 17 insertions(+), 17 deletions(-)
diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90
index d44ab79d1b..536d25e595 100644
--- a/src/parameterizations/vertical/MOM_kappa_shear.F90
+++ b/src/parameterizations/vertical/MOM_kappa_shear.F90
@@ -442,26 +442,26 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_
! Interpolate the various quantities to the corners, using masks.
do k=1,nz ; do I=IsB,IeB
- u_2d(I,k) = (u_in(I,j,k) * (G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k))) + &
- u_in(I,j+1,k) * (G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / &
+ u_2d(I,k) = (G%mask2dCu(I,j) * (u_in(I,j,k) * (h(i,j,k) + h(i+1,j,k))) + &
+ G%mask2dCu(I,j+1) * (u_in(I,j+1,k) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / &
((G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) + &
G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) + GV%H_subroundoff)
- v_2d(I,k) = (v_in(i,J,k) * (G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k))) + &
- v_in(i+1,J,k) * (G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / &
+ v_2d(I,k) = (G%mask2dCv(i,J) * (v_in(i,J,k) * (h(i,j,k) + h(i,j+1,k))) + &
+ G%mask2dCv(i+1,J) * (v_in(i+1,J,k) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / &
((G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) + &
G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) + GV%H_subroundoff)
I_hwt = 1.0 / (((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + &
(G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k))) + &
GV%H_subroundoff)
if (use_temperature) then
- T_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * T_in(i,j,k) + &
- (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * T_in(i+1,j+1,k)) + &
- ((G%mask2dT(i+1,j) * h(i+1,j,k)) * T_in(i+1,j,k) + &
- (G%mask2dT(i,j+1) * h(i,j+1,k)) * T_in(i,j+1,k)) ) * I_hwt
- S_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * S_in(i,j,k) + &
- (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * S_in(i+1,j+1,k)) + &
- ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + &
- (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt
+ T_2d(I,k) = ( (G%mask2dT(i,j) * (h(i,j,k) * T_in(i,j,k)) + &
+ G%mask2dT(i+1,j+1) * (h(i+1,j+1,k) * T_in(i+1,j+1,k))) + &
+ (G%mask2dT(i+1,j) * (h(i+1,j,k) * T_in(i+1,j,k)) + &
+ G%mask2dT(i,j+1) * (h(i,j+1,k) * T_in(i,j+1,k))) ) * I_hwt
+ S_2d(I,k) = ( (G%mask2dT(i,j) * (h(i,j,k) * S_in(i,j,k)) + &
+ G%mask2dT(i+1,j+1) * (h(i+1,j+1,k) * S_in(i+1,j+1,k))) + &
+ (G%mask2dT(i+1,j) * (h(i+1,j,k) * S_in(i+1,j,k)) + &
+ G%mask2dT(i,j+1) * (h(i,j+1,k) * S_in(i,j+1,k))) ) * I_hwt
endif
h_2d(I,k) = ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + &
(G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / &
@@ -472,8 +472,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_
((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + &
(G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 )
! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k)))
-! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + &
-! (h(i+1,j,k)**2 + h(i,j+1,k)**2)) * I_hwt
+! h_2d(I,k) = (((h(i,j,k)**2) + (h(i+1,j+1,k)**2)) + &
+! ((h(i+1,j,k)**2) + (h(i,j+1,k)**2))) * I_hwt
enddo ; enddo
if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB
rho_2d(I,k) = GV%Rlay(k)
@@ -1224,12 +1224,12 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int
! Store the squared shear at interfaces
S2(1) = 0.0 ; S2(nz+1) = 0.0
if (ks > 1) &
- S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (US%L_to_Z*I_dz_int(ks))**2
+ S2(ks) = (((u(ks)-u0(ks-1))**2) + ((v(ks)-v0(ks-1))**2)) * (US%L_to_Z*I_dz_int(ks))**2
do K=ks+1,ke
- S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (US%L_to_Z*I_dz_int(K))**2
+ S2(K) = (((u(k)-u(k-1))**2) + ((v(k)-v(k-1))**2)) * (US%L_to_Z*I_dz_int(K))**2
enddo
if (ke<nz) &
- S2(ke+1) = ((u0(ke+1)-u(ke))**2 + (v0(ke+1)-v(ke))**2) * (US%L_to_Z*I_dz_int(ke+1))**2
+ S2(ke+1) = (((u0(ke+1)-u(ke))**2) + ((v0(ke+1)-v(ke))**2)) * (US%L_to_Z*I_dz_int(ke+1))**2
! Store the buoyancy frequency at interfaces
N2(1) = 0.0 ; N2(nz+1) = 0.0
From f0c52ddb149e1c33c7f7276de2e3cee55b424bb6 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 12:50:54 -0500
Subject: [PATCH 20/30] (*)Parenthesize MOM_set_diffusivity for FMAs
Added parentheses to 4 expressions in add_drag_diffusivity, set_BBL_TKE and
add_LOTW_BBL_diffusivity setting the bottom-drag contributions to TKE and
friction velocity so that they will exhibit rotationally consistent solutions
when fused-multiply-adds are enabled. All answers are bitwise identical in
cases without FMAs, but answers could change when FMAs are enabled.
---
.../vertical/MOM_set_diffusivity.F90 | 32 +++++++++----------
1 file changed, 16 insertions(+), 16 deletions(-)
diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90
index 85c70efcfa..658bdca31d 100644
--- a/src/parameterizations/vertical/MOM_set_diffusivity.F90
+++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90
@@ -1324,10 +1324,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE,
! TKE_Ray has been initialized to 0 above.
if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * &
- ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + &
- G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + &
- (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + &
- G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2))
+ (((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2) + &
+ (G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2)) + &
+ ((G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2) + &
+ (G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)))
if (TKE_to_layer + TKE_Ray > 0.0) then
if (CS%BBL_mixing_as_max) then
@@ -1514,10 +1514,10 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo
! Add in additional energy input from bottom-drag against slopes (sides)
if (Rayleigh_drag) TKE_remaining = TKE_remaining + &
0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * &
- ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + &
- G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + &
- (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + &
- G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2))
+ (((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2) + &
+ (G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2)) + &
+ ((G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2) + &
+ (G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)))
! Exponentially decay TKE across the thickness of the layer.
! This is energy loss in addition to work done as mixing, apparently to Joule heating.
@@ -1910,15 +1910,15 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC)
do i=is,ie
visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * &
- ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + &
- G%areaCu(I,j)*(ustar(I)*ustar(I))) + &
- (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + &
- G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) )
+ (((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1))) + &
+ (G%areaCu(I,j)*(ustar(I)*ustar(I)))) + &
+ ((G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1))) + &
+ (G%areaCv(i,J)*(vstar(i,J)*vstar(i,J)))) ) )
visc%TKE_BBL(i,j) = US%L_to_Z**2 * &
- (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + &
- G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + &
- (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + &
- G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j))
+ ((((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1))) + &
+ (G%areaCu(I,j) * (ustar(I)*u2_bbl(I)))) + &
+ ((G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1))) + &
+ (G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J)))) )*G%IareaT(i,j))
enddo
enddo
!$OMP end parallel
From 64b851c4ee3daa9abd15a89e2648b80ed3a37153 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 18:59:11 -0500
Subject: [PATCH 21/30] (*)Parenthesize CorAdCalc for FMAs
Added parentheses to 20 expressions in CorAdCalc and one in gradKE to exhibit
rotationally consistent solutions when fused-multiply-adds are enabled. All
answers are bitwise identical in cases without FMAs, but answers could change
when FMAs are enabled.
---
src/core/MOM_CoriolisAdv.F90 | 76 ++++++++++++++++++------------------
1 file changed, 38 insertions(+), 38 deletions(-)
diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90
index 00a289ab9a..dce1acdd65 100644
--- a/src/core/MOM_CoriolisAdv.F90
+++ b/src/core/MOM_CoriolisAdv.F90
@@ -291,36 +291,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
- dvSdx(I,J) = ((-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J) - &
- (-Waves%us_y(i,J,k))*G%dyCv(i,J))
- duSdy(I,J) = ((-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1) - &
- (-Waves%us_x(I,j,k))*G%dxCu(I,j))
+ dvSdx(I,J) = (-Waves%us_y(i+1,J,k)*G%dyCv(i+1,J)) - &
+ (-Waves%us_y(i,J,k)*G%dyCv(i,J))
+ duSdy(I,J) = (-Waves%us_x(I,j+1,k)*G%dxCu(I,j+1)) - &
+ (-Waves%us_x(I,j,k)*G%dxCu(I,j))
enddo; enddo
endif
if (.not. Waves%Passive_Stokes_VF) then
do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
- dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J) - &
- (v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J))
- dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1) - &
- (u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j))
+ dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J)) - &
+ ((v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J))
+ dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1)) - &
+ ((u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j))
enddo; enddo
else
do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
- dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J) - v(i,J,k)*G%dyCv(i,J))
- dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1) - u(I,j,k)*G%dxCu(I,j))
+ dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))
+ dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))
enddo; enddo
endif
else
do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
- dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J) - v(i,J,k)*G%dyCv(i,J))
- dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1) - u(I,j,k)*G%dxCu(I,j))
+ dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))
+ dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))
enddo; enddo
endif
do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2
- hArea_v(i,J) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i,j+1) * h(i,j+1,k))
+ hArea_v(i,J) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i,j+1) * h(i,j+1,k)))
enddo ; enddo
do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1
- hArea_u(I,j) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i+1,j) * h(i+1,j,k))
+ hArea_u(I,j) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i+1,j) * h(i+1,j,k)))
enddo ; enddo
if (CS%Coriolis_En_Dis) then
@@ -667,8 +667,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! Energy conserving scheme, Sadourny 1975
do j=js,je ; do I=Isq,Ieq
CAu(I,j,k) = 0.25 * &
- (q(I,J) * (vh(i+1,J,k) + vh(i,J,k)) + &
- q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j)
+ ((q(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + &
+ (q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
enddo ; enddo
endif
elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then
@@ -681,8 +681,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
(CS%Coriolis_Scheme == AL_BLEND)) then
! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990
do j=js,je ; do I=Isq,Ieq
- CAu(I,j,k) = ((a(I,j) * vh(i+1,J,k) + c(I,j) * vh(i,J-1,k)) + &
- (b(I,j) * vh(i,J,k) + d(I,j) * vh(i+1,J-1,k))) * G%IdxCu(I,j)
+ CAu(I,j,k) = (((a(I,j) * vh(i+1,J,k)) + (c(I,j) * vh(i,J-1,k))) + &
+ ((b(I,j) * vh(i,J,k)) + (d(I,j) * vh(i+1,J-1,k)))) * G%IdxCu(I,j)
enddo ; enddo
elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then
! An enstrophy conserving scheme robust to vanishing layers
@@ -707,8 +707,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
(h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) * G%IdxCu(I,j)
elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then
VHeff = ((vh(i,J,k) + vh(i+1,J-1,k)) + (vh(i,J-1,k) + vh(i+1,J,k)) )
- QVHeff = 0.5*( (abs_vort(I,J)+abs_vort(I,J-1))*VHeff &
- -(abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff) )
+ QVHeff = 0.5*( ((abs_vort(I,J)+abs_vort(I,J-1))*VHeff) &
+ - ((abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff)) )
CAu(I,j,k) = (QVHeff / ( h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) ) * G%IdxCu(I,j)
endif
enddo ; enddo
@@ -717,7 +717,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
(CS%Coriolis_Scheme == AL_BLEND)) then ; do j=js,je ; do I=Isq,Ieq
CAu(I,j,k) = CAu(I,j,k) + &
- (ep_u(i,j)*uh(I-1,j,k) - ep_u(i+1,j)*uh(I+1,j,k)) * G%IdxCu(I,j)
+ ((ep_u(i,j)*uh(I-1,j,k)) - (ep_u(i+1,j)*uh(I+1,j,k))) * G%IdxCu(I,j)
enddo ; enddo ; endif
if (Stokes_VF) then
@@ -725,8 +725,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! Computing the diagnostic Stokes contribution to CAu
do j=js,je ; do I=Isq,Ieq
CAuS(I,j,k) = 0.25 * &
- (qS(I,J) * (vh(i+1,J,k) + vh(i,J,k)) + &
- qS(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j)
+ ((qS(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + &
+ (qS(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
enddo ; enddo
endif
endif
@@ -786,8 +786,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! Energy conserving scheme, Sadourny 1975
do J=Jsq,Jeq ; do i=is,ie
CAv(i,J,k) = - 0.25* &
- (q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + &
- q(I,J)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J)
+ ((q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + &
+ (q(I,J)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J)
enddo ; enddo
endif
elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then
@@ -800,10 +800,10 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
(CS%Coriolis_Scheme == AL_BLEND)) then
! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990
do J=Jsq,Jeq ; do i=is,ie
- CAv(i,J,k) = - ((a(I-1,j) * uh(I-1,j,k) + &
- c(I,j+1) * uh(I,j+1,k)) &
- + (b(I,j) * uh(I,j,k) + &
- d(I-1,j+1) * uh(I-1,j+1,k))) * G%IdyCv(i,J)
+ CAv(i,J,k) = - (((a(I-1,j) * uh(I-1,j,k)) + &
+ (c(I,j+1) * uh(I,j+1,k))) &
+ + ((b(I,j) * uh(I,j,k)) + &
+ (d(I-1,j+1) * uh(I-1,j+1,k)))) * G%IdyCv(i,J)
enddo ; enddo
elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then
! An enstrophy conserving scheme robust to vanishing layers
@@ -830,8 +830,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then
UHeff = ((uh(I ,j ,k)+uh(I-1,j+1,k)) + &
(uh(I-1,j ,k)+uh(I ,j+1,k)) )
- QUHeff = 0.5*( (abs_vort(I,J)+abs_vort(I-1,J))*UHeff &
- -(abs_vort(I,J)-abs_vort(I-1,J))*abs(UHeff) )
+ QUHeff = 0.5*( ((abs_vort(I,J)+abs_vort(I-1,J))*UHeff) &
+ - ((abs_vort(I,J)-abs_vort(I-1,J))*abs(UHeff)) )
CAv(i,J,k) = - QUHeff / &
(h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J)
endif
@@ -841,7 +841,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
(CS%Coriolis_Scheme == AL_BLEND)) then ; do J=Jsq,Jeq ; do i=is,ie
CAv(i,J,k) = CAv(i,J,k) + &
- (ep_v(i,j)*vh(i,J-1,k) - ep_v(i,j+1)*vh(i,J+1,k)) * G%IdyCv(i,J)
+ ((ep_v(i,j)*vh(i,J-1,k)) - (ep_v(i,j+1)*vh(i,J+1,k))) * G%IdyCv(i,J)
enddo ; enddo ; endif
if (Stokes_VF) then
@@ -849,8 +849,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! Computing the diagnostic Stokes contribution to CAv
do J=Jsq,Jeq ; do i=is,ie
CAvS(I,j,k) = 0.25 * &
- (qS(I,J) * (uh(I,j+1,k) + uh(I,j,k)) + &
- qS(I,J-1) * (uh(I-1,j,k) + uh(I-1,j+1,k))) * G%IdyCv(i,J)
+ ((qS(I,J) * (uh(I,j+1,k) + uh(I,j,k))) + &
+ (qS(I,J-1) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J)
enddo; enddo
endif
endif
@@ -997,10 +997,10 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS)
! identified in Arakawa & Lamb 1982 as important for KE conservation. It
! also includes the possibility of partially-blocked tracer cell faces.
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- KE(i,j) = ( ( G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k)) + &
- G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k)) ) + &
- ( G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k)) + &
- G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) )*0.25*G%IareaT(i,j)
+ KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k))) + &
+ (G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k))) ) + &
+ ( (G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k))) + &
+ (G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k))) ) )*0.25*G%IareaT(i,j)
enddo ; enddo
elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then
! The following discretization of KE is based on the one-dimensional Gudonov
From 46e8b661ed931ccc91af2503115ff801067e63c7 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 1 Mar 2024 18:59:28 -0500
Subject: [PATCH 22/30] (*)Parenthesize MOM_barotropic for FMAs
Added parentheses to 18 expressions in btstep, and one more each in set_dtbt
and barotropic_init to exhibit rotationally consistent solutions when
fused-multiply-adds are enabled. All answers are bitwise identical in cases
without FMAs, but answers could change when FMAs are enabled.
---
src/core/MOM_barotropic.F90 | 94 ++++++++++++++++++-------------------
1 file changed, 47 insertions(+), 47 deletions(-)
diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90
index f3d01bd886..0d30cd8671 100644
--- a/src/core/MOM_barotropic.F90
+++ b/src/core/MOM_barotropic.F90
@@ -915,10 +915,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
do J=js-1,je ; do I=is-1,ie
q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (max((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + &
- G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0)) + &
- (G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + &
- G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0)), h_neglect) )
+ (max(((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + &
+ (G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + &
+ ((G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + &
+ (G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_neglect) )
enddo ; enddo
else
!$OMP parallel do default(shared)
@@ -933,8 +933,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
do J=js-1,je ; do I=is-1,ie
q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (max((G%areaT(i,j) * eta_in(i,j) + G%areaT(i+1,j+1) * eta_in(i+1,j+1)) + &
- (G%areaT(i+1,j) * eta_in(i+1,j) + G%areaT(i,j+1) * eta_in(i,j+1)), h_neglect) )
+ (max(((G%areaT(i,j) * eta_in(i,j)) + (G%areaT(i+1,j+1) * eta_in(i+1,j+1))) + &
+ ((G%areaT(i+1,j) * eta_in(i+1,j)) + (G%areaT(i,j+1) * eta_in(i,j+1))), h_neglect) )
enddo ; enddo
endif
@@ -1477,14 +1477,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
!$OMP parallel do default(shared)
do j=js,je ; do I=is-1,ie
Cor_ref_u(I,j) = &
- ((azon(I,j) * vbt_Cor(i+1,j) + czon(I,j) * vbt_Cor(i ,j-1)) + &
- (bzon(I,j) * vbt_Cor(i ,j) + dzon(I,j) * vbt_Cor(i+1,j-1)))
+ (((azon(I,j) * vbt_Cor(i+1,j)) + (czon(I,j) * vbt_Cor(i ,j-1))) + &
+ ((bzon(I,j) * vbt_Cor(i ,j)) + (dzon(I,j) * vbt_Cor(i+1,j-1))))
enddo ; enddo
!$OMP parallel do default(shared)
do J=js-1,je ; do i=is,ie
Cor_ref_v(i,J) = -1.0 * &
- ((amer(I-1,j) * ubt_Cor(I-1,j) + cmer(I ,j+1) * ubt_Cor(I ,j+1)) + &
- (bmer(I ,j) * ubt_Cor(I ,j) + dmer(I-1,j+1) * ubt_Cor(I-1,j+1)))
+ (((amer(I-1,j) * ubt_Cor(I-1,j)) + (cmer(I ,j+1) * ubt_Cor(I ,j+1))) + &
+ ((bmer(I ,j) * ubt_Cor(I ,j)) + (dmer(I-1,j+1) * ubt_Cor(I-1,j+1))))
enddo ; enddo
! Now start new halo updates.
@@ -1645,16 +1645,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! gravity waves, but it is a conservative estimate since it ignores the
! stabilizing effect of the bottom drag.
Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*bebt)) * (G%IareaT(i,j) * &
- ((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j)) + &
- gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j))) + &
- (gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + &
- gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + &
+ (((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j))) + &
+ (gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j)))) + &
+ ((gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J))) + &
+ (gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1))))) + &
((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
- H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j))**2 + (G%IdyT(i,j))**2), &
+ H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j)**2) + (G%IdyT(i,j)**2)), &
G%IareaT(i,j) * &
- ((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + &
- (Datv(i,J)*G%IdyCv(i,J) + Datv(i,J-1)*G%IdyCv(i,J-1)) ) )
+ (((Datu(I,j)*G%IdxCu(I,j)) + (Datu(I-1,j)*G%IdxCu(I-1,j))) + &
+ ((Datv(i,J)*G%IdyCv(i,J)) + (Datv(i,J-1)*G%IdyCv(i,J-1))) ) )
dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / &
(dtbt**2 * H_eff_dx2)
@@ -1974,10 +1974,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! On odd-steps, update v first.
!$OMP do schedule(static)
do J=jsv-1,jev ; do i=isv-1,iev+1
- Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + &
- (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J)
- PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - &
- (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * &
+ Cor_v(i,J) = -1.0*(((amer(I-1,j) * ubt(I-1,j)) + (cmer(I,j+1) * ubt(I,j+1))) + &
+ ((bmer(I,j) * ubt(I,j)) + (dmer(I-1,j+1) * ubt(I-1,j+1)))) - Cor_ref_v(i,J)
+ PFv(i,J) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j)) - &
+ ((eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1))) * &
dgeo_de * CS%IdyCv(i,J)
enddo ; enddo
!$OMP end do nowait
@@ -2049,11 +2049,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! Now update the zonal velocity.
!$OMP do schedule(static)
do j=jsv,jev ; do I=isv-1,iev
- Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + &
- (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - &
+ Cor_u(I,j) = (((azon(I,j) * vbt(i+1,J)) + (czon(I,j) * vbt(i,J-1))) + &
+ ((bzon(I,j) * vbt(i,J)) + (dzon(I,j) * vbt(i+1,J-1)))) - &
Cor_ref_u(I,j)
- PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - &
- (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * &
+ PFu(I,j) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j)) - &
+ ((eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j))) * &
dgeo_de * CS%IdxCu(I,j)
enddo ; enddo
!$OMP end do nowait
@@ -2128,11 +2128,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! On even steps, update u first.
!$OMP do schedule(static)
do j=jsv-1,jev+1 ; do I=isv-1,iev
- Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + &
- (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - &
+ Cor_u(I,j) = (((azon(I,j) * vbt(i+1,J)) + (czon(I,j) * vbt(i,J-1))) + &
+ ((bzon(I,j) * vbt(i,J)) + (dzon(I,j) * vbt(i+1,J-1)))) - &
Cor_ref_u(I,j)
- PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - &
- (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * &
+ PFu(I,j) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j)) - &
+ ((eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j))) * &
dgeo_de * CS%IdxCu(I,j)
enddo ; enddo
!$OMP end do nowait
@@ -2206,20 +2206,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (CS%use_old_coriolis_bracket_bug) then
!$OMP do schedule(static)
do J=jsv-1,jev ; do i=isv,iev
- Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + &
- (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J)
- PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - &
- (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * &
+ Cor_v(i,J) = -1.0*(((amer(I-1,j) * ubt(I-1,j)) + (bmer(I,j) * ubt(I,j))) + &
+ ((cmer(I,j+1) * ubt(I,j+1)) + (dmer(I-1,j+1) * ubt(I-1,j+1)))) - Cor_ref_v(i,J)
+ PFv(i,J) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j)) - &
+ ((eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1))) * &
dgeo_de * CS%IdyCv(i,J)
enddo ; enddo
!$OMP end do nowait
else
!$OMP do schedule(static)
do J=jsv-1,jev ; do i=isv,iev
- Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + &
- (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J)
- PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - &
- (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * &
+ Cor_v(i,J) = -1.0*(((amer(I-1,j) * ubt(I-1,j)) + (cmer(I,j+1) * ubt(I,j+1))) + &
+ ((bmer(I,j) * ubt(I,j)) + (dmer(I-1,j+1) * ubt(I-1,j+1)))) - Cor_ref_v(i,J)
+ PFv(i,J) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j)) - &
+ ((eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1))) * &
dgeo_de * CS%IdyCv(i,J)
enddo ; enddo
!$OMP end do nowait
@@ -2576,14 +2576,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
do k=1,nz
do j=js,je ; do I=is-1,ie
accel_layer_u(I,j,k) = (u_accel_bt(I,j) - &
- ((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j) - &
- (pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j)) * CS%IdxCu(I,j) )
+ (((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - &
+ ((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j) )
if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0
enddo ; enddo
do J=js-1,je ; do i=is,ie
accel_layer_v(i,J,k) = (v_accel_bt(i,J) - &
- ((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1) - &
- (pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j)) * CS%IdyCv(i,J) )
+ (((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - &
+ ((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J) )
if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0
enddo ; enddo
enddo
@@ -2904,8 +2904,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add)
! This is pretty accurate for gravity waves, but it is a conservative
! estimate since it ignores the stabilizing effect of the bottom drag.
Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * &
- ((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + &
- (gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + &
+ (((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j)) + (gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j))) + &
+ ((gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J)) + (gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1)))) + &
((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2
@@ -4850,10 +4850,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS,
if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then
CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (Z_to_H * max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + &
- G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + &
- (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + &
- G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_subroundoff) )
+ (Z_to_H * max((((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0)) + &
+ (G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0))) + &
+ ((G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0)) + &
+ (G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0)))), GV%H_subroundoff) )
else ! All four h points are masked out so q_D(I,J) will is meaningless
CS%q_D(I,J) = 0.
endif
From 6216fa1f5f7be221f08e9143232e1f90a619837f Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Sat, 2 Mar 2024 08:11:04 -0500
Subject: [PATCH 23/30] (*)Parenthesize MOM_lateral_mixing_coeffs for FMAs
Added parentheses to 19 expressions in 5 routines (calc_Visbeck_coeffs_old,
calc_Eady_growth_rate_2D, calc_slope_functions_using_just_e,
calc_QG_Leith_viscosity VarMix_init) in MOM_lateral_mixing_coeffs.F90 to give
rotationally consistent solutions when fused-multiply-adds are enabled. Also
reordered terms in a sum in the calculation of beta_dx2_u to mirror that of
beta_dx2_v, also for rotational symmetry with FMAs. All answers are bitwise
identical in cases without FMAs, but answers could change for some parameter
settings when FMAs are enabled.
---
.../lateral/MOM_lateral_mixing_coeffs.F90 | 78 +++++++++----------
1 file changed, 39 insertions(+), 39 deletions(-)
diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
index 55e448ec90..d124450536 100644
--- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
+++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
@@ -593,8 +593,8 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C
wNE = G%mask2dCv(i+1,J ) * ( (h(i+1,j,k)*h(i+1,j+1,k)) * (h(i+1,j,k-1)*h(i+1,j+1,k-1)) )
wSW = G%mask2dCv(i ,J-1) * ( (h(i ,j,k)*h(i ,j-1,k)) * (h(i ,j,k-1)*h(i ,j-1,k-1)) )
S2 = slope_x(I,j,K)**2 + &
- ((wNW*slope_y(i,J,K)**2 + wSE*slope_y(i+1,J-1,K)**2) + &
- (wNE*slope_y(i+1,J,K)**2 + wSW*slope_y(i,J-1,K)**2) ) / &
+ (((wNW*slope_y(i,J,K)**2) + (wSE*slope_y(i+1,J-1,K)**2)) + &
+ ((wNE*slope_y(i+1,J,K)**2) + (wSW*slope_y(i,J-1,K)**2)) ) / &
( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 )
if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2
@@ -629,8 +629,8 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C
wNE = G%mask2dCu(I,j+1) * ( (h(i,j+1,k)*h(i+1,j+1,k)) * (h(i,j+1,k-1)*h(i+1,j+1,k-1)) )
wSW = G%mask2dCu(I-1,j) * ( (h(i,j ,k)*h(i-1,j ,k)) * (h(i,j ,k-1)*h(i-1,j ,k-1)) )
S2 = slope_y(i,J,K)**2 + &
- ((wSE*slope_x(I,j,K)**2 + wNW*slope_x(I-1,j+1,K)**2) + &
- (wNE*slope_x(I,j+1,K)**2 + wSW*slope_x(I-1,j,K)**2) ) / &
+ (((wSE*slope_x(I,j,K)**2) + (wNW*slope_x(I-1,j+1,K)**2)) + &
+ ((wNE*slope_x(I,j+1,K)**2) + (wSW*slope_x(I-1,j,K)**2)) ) / &
( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 )
if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2
@@ -800,15 +800,15 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN,
do j=G%jsc,G%jec
do I=G%isc-1,G%iec
CS%SN_u(I,j) = sqrt( SN_cpy(I,j)**2 &
- + 0.25*( (CS%SN_v(i,J)**2 + CS%SN_v(i+1,J-1)**2) &
- + (CS%SN_v(i+1,J)**2 + CS%SN_v(i,J-1)**2) ) )
+ + 0.25*( ((CS%SN_v(i,J)**2) + (CS%SN_v(i+1,J-1)**2)) &
+ + ((CS%SN_v(i+1,J)**2) + (CS%SN_v(i,J-1)**2)) ) )
enddo
enddo
do J=G%jsc-1,G%jec
do i=G%isc,G%iec
CS%SN_v(i,J) = sqrt( CS%SN_v(i,J)**2 &
- + 0.25*( (SN_cpy(I,j)**2 + SN_cpy(I-1,j+1)**2) &
- + (SN_cpy(I,j+1)**2 + SN_cpy(I-1,j)**2) ) )
+ + 0.25*( ((SN_cpy(I,j)**2) + (SN_cpy(I-1,j+1)**2)) &
+ + ((SN_cpy(I,j+1)**2) + (SN_cpy(I-1,j)**2)) ) )
enddo
enddo
@@ -920,7 +920,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop
! Calculate N*S*h from this layer and add to the sum
do j=js,je ; do I=is-1,ie
S2 = ( E_x(I,j)**2 + 0.25*( &
- (E_y(i,J)**2+E_y(i+1,J-1)**2) + (E_y(i+1,J)**2+E_y(i,J-1)**2) ) )
+ ((E_y(i,J)**2) + (E_y(i+1,J-1)**2)) + ((E_y(i+1,J)**2) + (E_y(i,J-1)**2)) ) )
if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) S2 = 0.0
Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect)
@@ -931,7 +931,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop
enddo ; enddo
do J=js-1,je ; do i=is,ie
S2 = ( E_y(i,J)**2 + 0.25*( &
- (E_x(I,j)**2+E_x(I-1,j+1)**2) + (E_x(I,j+1)**2+E_x(I-1,j)**2) ) )
+ ((E_x(I,j)**2) + (E_x(I-1,j+1)**2)) + ((E_x(I,j+1)**2) + (E_x(I-1,j)**2)) ) )
if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) S2 = 0.0
Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect)
@@ -1105,16 +1105,16 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, dz, k, div_xx_dx, div_xx_dy
do J=js-2,je+1 ; do i=is-1,ie+1
f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) )
vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * &
- ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) &
- + ( h_at_u(I-1,j) * dslopex_dz(I-1,j) + h_at_u(I,j+1) * dslopex_dz(I,j+1) ) ) / &
+ ( ( (h_at_u(I,j) * dslopex_dz(I,j)) + (h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1)) ) &
+ + ( (h_at_u(I-1,j) * dslopex_dz(I-1,j)) + (h_at_u(I,j+1) * dslopex_dz(I,j+1)) ) ) / &
( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff)
enddo ; enddo
do j=js-1,je+1 ; do I=is-2,ie+1
f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) )
vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * &
- ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) &
- + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / &
+ ( ( (h_at_v(i,J) * dslopey_dz(i,J)) + (h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1)) ) &
+ + ( (h_at_v(i,J-1) * dslopey_dz(i,J-1)) + (h_at_v(i+1,J) * dslopey_dz(i+1,J)) ) ) / &
( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff)
enddo ; enddo
endif ! k > 1
@@ -1515,35 +1515,35 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
endif
do J=js-1,Jeq ; do I=is-1,Ieq
- CS%f2_dx2_q(I,J) = (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * &
+ CS%f2_dx2_q(I,J) = ((G%dxBu(I,J)**2) + (G%dyBu(I,J)**2)) * &
max(G%Coriolis2Bu(I,J), absurdly_small_freq**2)
- CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J))**2 + (G%dyBu(I,J))**2) * (sqrt(0.5 * &
- ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
- ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
- ((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2) ) ))
+ CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J)**2) + (G%dyBu(I,J)**2)) * (sqrt(0.5 * &
+ ( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + &
+ (((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2)) + &
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + &
+ (((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2)) ) ))
enddo ; enddo
do j=js,je ; do I=is-1,Ieq
- CS%f2_dx2_u(I,j) = (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * &
+ CS%f2_dx2_u(I,j) = ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2)) * &
max(0.5* (G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I,J-1)), absurdly_small_freq**2)
- CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j))**2 + (G%dyCu(I,j))**2) * (sqrt( &
- 0.25*( (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2 + &
- ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + &
- (((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2 + &
- ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) ) + &
- ((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 ))
+ CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2)) * (sqrt( &
+ ((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
+ 0.25*( ((((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
+ (((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2)) + &
+ ((((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2) + &
+ (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2)) ) ))
enddo ; enddo
do J=js-1,Jeq ; do i=is,ie
- CS%f2_dx2_v(i,J) = ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * &
+ CS%f2_dx2_v(i,J) = ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2)) * &
max(0.5*(G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I-1,J)), absurdly_small_freq**2)
- CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * (sqrt( &
+ CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2)) * (sqrt( &
((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
- 0.25*( (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
- ((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2) + &
- (((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2 + &
- ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) ))
+ 0.25*( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + &
+ (((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2)) + &
+ ((((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2) + &
+ (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ) ))
enddo ; enddo
endif
@@ -1571,15 +1571,15 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
allocate(CS%beta_dx2_h(isd:ied,jsd:jed), source=0.0)
allocate(CS%f2_dx2_h(isd:ied,jsd:jed), source=0.0)
do j=js-1,je+1 ; do i=is-1,ie+1
- CS%f2_dx2_h(i,j) = (G%dxT(i,j)**2 + G%dyT(i,j)**2) * &
+ CS%f2_dx2_h(i,j) = ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) * &
max(0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))), &
absurdly_small_freq**2)
- CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j))**2 + (G%dyT(i,j))**2) * (sqrt(0.5 * &
- ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
- ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
- ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) ))
+ CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) * (sqrt(0.5 * &
+ ( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + &
+ (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + &
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + &
+ (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ) ))
enddo ; enddo
endif
From ffef92f7fa3c9de3257931623bf8cbbfd3539225 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Thu, 18 Apr 2024 19:21:34 -0400
Subject: [PATCH 24/30] (*)Parenthesize MOM_hor_visc for FMAs
Added parentheses to 40 expressions horizontal_viscosity and another 14
expressions in in hor_visc_init and 3 more in align_aniso_tensor_to_grid to give
rotationally consistent solutions when fused-multiply-adds are enabled. Also
swapped the order of two terms in the expression for Del2u to mirror the order
of the corresponding terms in Del2v for rotational symmetry with FMAs. All
answers are bitwise identical in cases without FMAs, but answers could change
when FMAs are enabled.
---
.../lateral/MOM_hor_visc.F90 | 266 +++++++++---------
1 file changed, 133 insertions(+), 133 deletions(-)
diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90
index 2eef171bf5..6685070682 100644
--- a/src/parameterizations/lateral/MOM_hor_visc.F90
+++ b/src/parameterizations/lateral/MOM_hor_visc.F90
@@ -512,10 +512,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Calculate the barotropic horizontal tension
do j=js-2,je+2 ; do i=is-2,ie+2
- dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - &
- G%IdyCu(I-1,j) * ubtav(I-1,j))
- dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - &
- G%IdxCv(i,J-1) * vbtav(i,J-1))
+ dudx_bt(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * ubtav(I,j)) - &
+ (G%IdyCu(I-1,j) * ubtav(I-1,j)))
+ dvdy_bt(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * vbtav(i,J)) - &
+ (G%IdxCv(i,J-1) * vbtav(i,J-1)))
enddo ; enddo
do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j)
@@ -523,10 +523,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Components for the barotropic shearing strain
do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2
- dvdx_bt(I,J) = CS%DY_dxBu(I,J)*(vbtav(i+1,J)*G%IdyCv(i+1,J) &
- - vbtav(i,J)*G%IdyCv(i,J))
- dudy_bt(I,J) = CS%DX_dyBu(I,J)*(ubtav(I,j+1)*G%IdxCu(I,j+1) &
- - ubtav(I,j)*G%IdxCu(I,j))
+ dvdx_bt(I,J) = CS%DY_dxBu(I,J)*((vbtav(i+1,J)*G%IdyCv(i+1,J)) &
+ - (vbtav(i,J)*G%IdyCv(i,J)))
+ dudy_bt(I,J) = CS%DX_dyBu(I,J)*((ubtav(I,j+1)*G%IdxCu(I,j+1)) &
+ - (ubtav(I,j)*G%IdxCu(I,j)))
enddo ; enddo
if (CS%no_slip) then
@@ -653,35 +653,35 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Calculate horizontal tension
do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
- dudx(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - &
- G%IdyCu(I-1,j) * u(I-1,j,k))
- dvdy(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - &
- G%IdxCv(i,J-1) * v(i,J-1,k))
+ dudx(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * u(I,j,k)) - &
+ (G%IdyCu(I-1,j) * u(I-1,j,k)))
+ dvdy(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * v(i,J,k)) - &
+ (G%IdxCv(i,J-1) * v(i,J-1,k)))
sh_xx(i,j) = dudx(i,j) - dvdy(i,j)
enddo ; enddo
! Components for the shearing strain
do J=js_vort,je_vort ; do I=is_vort,ie_vort
- dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J))
- dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j))
+ dvdx(I,J) = CS%DY_dxBu(I,J)*((v(i+1,J,k)*G%IdyCv(i+1,J)) - (v(i,J,k)*G%IdyCv(i,J)))
+ dudy(I,J) = CS%DX_dyBu(I,J)*((u(I,j+1,k)*G%IdxCu(I,j+1)) - (u(I,j,k)*G%IdxCu(I,j)))
enddo ; enddo
if (CS%use_Leithy) then
! Calculate horizontal tension from smoothed velocity
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j,k) - &
- G%IdyCu(I-1,j) * u_smooth(I-1,j,k))
- dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J,k) - &
- G%IdxCv(i,J-1) * v_smooth(i,J-1,k))
+ dudx_smooth(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * u_smooth(I,j,k)) - &
+ (G%IdyCu(I-1,j) * u_smooth(I-1,j,k)))
+ dvdy_smooth(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * v_smooth(i,J,k)) - &
+ (G%IdxCv(i,J-1) * v_smooth(i,J-1,k)))
sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j)
enddo ; enddo
! Components for the shearing strain from smoothed velocity
do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh
dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * &
- (v_smooth(i+1,J,k)*G%IdyCv(i+1,J) - v_smooth(i,J,k)*G%IdyCv(i,J))
+ ((v_smooth(i+1,J,k)*G%IdyCv(i+1,J)) - (v_smooth(i,J,k)*G%IdyCv(i,J)))
dudy_smooth(I,J) = CS%DX_dyBu(I,J) * &
- (u_smooth(I,j+1,k)*G%IdxCu(I,j+1) - u_smooth(I,j,k)*G%IdxCu(I,j))
+ ((u_smooth(I,j+1,k)*G%IdxCu(I,j+1)) - (u_smooth(I,j,k)*G%IdxCu(I,j)))
enddo ; enddo
endif ! use Leith+E
@@ -873,12 +873,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u)
if (CS%biharmonic) then
do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1
- Del2u(I,j) = CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*sh_xx(i+1,j) - CS%dy2h(i,j)*sh_xx(i,j)) + &
- CS%Idx2dyCu(I,j)*(CS%dx2q(I,J)*sh_xy(I,J) - CS%dx2q(I,J-1)*sh_xy(I,J-1))
+ Del2u(I,j) = CS%Idx2dyCu(I,j) * ((CS%dx2q(I,J)*sh_xy(I,J)) - (CS%dx2q(I,J-1)*sh_xy(I,J-1))) + &
+ CS%Idxdy2u(I,j) * ((CS%dy2h(i+1,j)*sh_xx(i+1,j)) - (CS%dy2h(i,j)*sh_xx(i,j)))
enddo ; enddo
do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1
- Del2v(i,J) = CS%Idxdy2v(i,J)*(CS%dy2q(I,J)*sh_xy(I,J) - CS%dy2q(I-1,J)*sh_xy(I-1,J)) - &
- CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*sh_xx(i,j+1) - CS%dx2h(i,j)*sh_xx(i,j))
+ Del2v(i,J) = CS%Idxdy2v(i,J) * ((CS%dy2q(I,J)*sh_xy(I,J)) - (CS%dy2q(I-1,J)*sh_xy(I-1,J))) - &
+ CS%Idx2dyCv(i,J) * ((CS%dx2h(i,j+1)*sh_xx(i,j+1)) - (CS%dx2h(i,j)*sh_xx(i,j)))
enddo ; enddo
if (apply_OBC) then ; if (OBC%zero_biharmonic) then
do n=1,OBC%number_of_segments
@@ -927,12 +927,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Vorticity gradient
do J=js-2,je_Kh ; do i=is_Kh-1,ie_Kh+1
DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
- vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j))
+ vort_xy_dx(i,J) = DY_dxBu * ((vort_xy(I,J) * G%IdyCu(I,j)) - (vort_xy(I-1,J) * G%IdyCu(I-1,j)))
enddo ; enddo
do j=js_Kh-1,je_Kh+1 ; do I=is-2,ie_Kh
DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
- vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1))
+ vort_xy_dy(I,j) = DX_dyBu * ((vort_xy(I,J) * G%IdxCv(i,J)) - (vort_xy(I,J-1) * G%IdxCv(i,J-1)))
enddo ; enddo
if (CS%use_Leithy) then
@@ -940,13 +940,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
do J=js_Kh-1,je_Kh ; do i=is_Kh,ie_Kh
DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
vort_xy_dx_smooth(i,J) = DY_dxBu * &
- (vort_xy_smooth(I,J) * G%IdyCu(I,j) - vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j))
+ ((vort_xy_smooth(I,J) * G%IdyCu(I,j)) - (vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j)))
enddo ; enddo
do j=js_Kh,je_Kh ; do I=is_Kh-1,ie_Kh
DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
vort_xy_dy_smooth(I,j) = DX_dyBu * &
- (vort_xy_smooth(I,J) * G%IdxCv(i,J) - vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1))
+ ((vort_xy_smooth(I,J) * G%IdxCv(i,J)) - (vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1)))
enddo ; enddo
endif ! If Leithy
@@ -956,8 +956,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
- Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + &
- DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j))
+ Del2vort_q(I,J) = DY_dxBu * ((vort_xy_dx(i+1,J) * G%IdyCv(i+1,J)) - (vort_xy_dx(i,J) * G%IdyCv(i,J))) + &
+ DX_dyBu * ((vort_xy_dy(I,j+1) * G%IdyCu(I,j+1)) - (vort_xy_dy(I,j) * G%IdyCu(I,j)))
enddo ; enddo
! endif
@@ -978,12 +978,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Magnitude of divergence gradient
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- grad_div_mag_h(i,j) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2 + &
- (0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2)
+ grad_div_mag_h(i,j) = sqrt(((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2) + &
+ ((0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2))
enddo ; enddo
do J=js-1,Jeq ; do I=is-1,Ieq
- grad_div_mag_q(I,J) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2 + &
- (0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2)
+ grad_div_mag_q(I,J) = sqrt(((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2) + &
+ ((0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2))
enddo ; enddo
else
@@ -1016,12 +1016,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%use_QG_Leith_visc) then
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- grad_vort_mag_h_2d(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + &
- (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 )
+ grad_vort_mag_h_2d(i,j) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2) + &
+ ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2) )
enddo ; enddo
do J=js-1,Jeq ; do I=is-1,Ieq
- grad_vort_mag_q_2d(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + &
- (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 )
+ grad_vort_mag_q_2d(I,J) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2) + &
+ ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2) )
enddo ; enddo
! This accumulates terms, some of which are in VarMix.
@@ -1031,20 +1031,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
endif
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- grad_vort_mag_h(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + &
- (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 )
+ grad_vort_mag_h(i,j) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2) + &
+ ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2) )
enddo ; enddo
do J=js-1,Jeq ; do I=is-1,Ieq
- grad_vort_mag_q(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + &
- (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 )
+ grad_vort_mag_q(I,J) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2) + &
+ ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2) )
enddo ; enddo
if (CS%use_Leithy) then
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- vert_vort_mag_smooth(i,j) = SQRT((0.5*(vort_xy_dx_smooth(i,J) + &
- vort_xy_dx_smooth(i,J-1)))**2 + &
- (0.5*(vort_xy_dy_smooth(I,j) + &
- vort_xy_dy_smooth(I-1,j)))**2 )
+ vert_vort_mag_smooth(i,j) = SQRT(((0.5*(vort_xy_dx_smooth(i,J) + &
+ vort_xy_dx_smooth(i,J-1)))**2) + &
+ ((0.5*(vort_xy_dy_smooth(I,j) + &
+ vort_xy_dy_smooth(I-1,j)))**2) )
enddo ; enddo
endif ! Leithy
@@ -1053,8 +1053,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
sh_xx_sq = sh_xx(i,j)**2
- sh_xy_sq = 0.25 * ( (sh_xy(I-1,J-1)**2 + sh_xy(I,J)**2) &
- + (sh_xy(I-1,J)**2 + sh_xy(I,J-1)**2) )
+ sh_xy_sq = 0.25 * ( ((sh_xy(I-1,J-1)**2) + (sh_xy(I,J)**2)) &
+ + ((sh_xy(I-1,J)**2) + (sh_xy(I,J-1)**2)) )
Shear_mag(i,j) = sqrt(sh_xx_sq + sh_xy_sq)
enddo ; enddo
endif
@@ -1360,9 +1360,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
endif
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- d_del2u = G%IdyCu(I,j) * Del2u(I,j) - G%IdyCu(I-1,j) * Del2u(I-1,j)
- d_del2v = G%IdxCv(i,J) * Del2v(i,J) - G%IdxCv(i,J-1) * Del2v(i,J-1)
- d_str = Ah(i,j) * (CS%DY_dxT(i,j) * d_del2u - CS%DX_dyT(i,j) * d_del2v)
+ d_del2u = (G%IdyCu(I,j) * Del2u(I,j)) - (G%IdyCu(I-1,j) * Del2u(I-1,j))
+ d_del2v = (G%IdxCv(i,J) * Del2v(i,J)) - (G%IdxCv(i,J-1) * Del2v(i,J-1))
+ d_str = Ah(i,j) * ((CS%DY_dxT(i,j) * d_del2u) - (CS%DX_dyT(i,j) * d_del2v))
str_xx(i,j) = str_xx(i,j) + d_str
@@ -1376,8 +1376,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%biharmonic) then
! Gradient of Laplacian, for use in bi-harmonic term
do J=js-1,Jeq ; do I=is-1,Ieq
- dDel2vdx(I,J) = CS%DY_dxBu(I,J)*(Del2v(i+1,J)*G%IdyCv(i+1,J) - Del2v(i,J)*G%IdyCv(i,J))
- dDel2udy(I,J) = CS%DX_dyBu(I,J)*(Del2u(I,j+1)*G%IdxCu(I,j+1) - Del2u(I,j)*G%IdxCu(I,j))
+ dDel2vdx(I,J) = CS%DY_dxBu(I,J)*((Del2v(i+1,J)*G%IdyCv(i+1,J)) - (Del2v(i,J)*G%IdyCv(i,J)))
+ dDel2udy(I,J) = CS%DX_dyBu(I,J)*((Del2u(I,j+1)*G%IdxCu(I,j+1)) - (Del2u(I,j)*G%IdxCu(I,j)))
enddo ; enddo
! Adjust contributions to shearing strain on open boundaries.
if (apply_OBC) then ; if (OBC%zero_strain .or. OBC%freeslip_strain) then
@@ -1409,8 +1409,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
do J=js-1,Jeq ; do I=is-1,Ieq
sh_xy_sq = sh_xy(I,J)**2
- sh_xx_sq = 0.25 * ( (sh_xx(i,j)**2 + sh_xx(i+1,j+1)**2) &
- + (sh_xx(i,j+1)**2 + sh_xx(i+1,j)**2) )
+ sh_xx_sq = 0.25 * ( ((sh_xx(i,j)**2) + (sh_xx(i+1,j+1)**2)) &
+ + ((sh_xx(i,j+1)**2) + (sh_xx(i+1,j)**2)) )
Shear_mag(I,J) = sqrt(sh_xy_sq + sh_xx_sq)
enddo ; enddo
endif
@@ -1641,7 +1641,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%Re_Ah > 0.0) then
do J=js-1,Jeq ; do I=is-1,Ieq
- KE = 0.125 * ((u(I,j,k) + u(I,j+1,k))**2 + (v(i,J,k) + v(i+1,J,k))**2)
+ KE = 0.125 * (((u(I,j,k) + u(I,j+1,k))**2) + ((v(i,J,k) + v(i+1,J,k))**2))
Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J)
enddo ; enddo
endif
@@ -1743,8 +1743,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent.
do j=js,je ; do I=Isq,Ieq
- diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j)*str_xx(i,j) - CS%dy2h(i+1,j)*str_xx(i+1,j)) + &
- G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - CS%dx2q(I,J)*str_xy(I,J))) * &
+ diffu(I,j,k) = ((G%IdxCu(I,j)*((CS%dx2q(I,J-1)*str_xy(I,J-1)) - (CS%dx2q(I,J)*str_xy(I,J))) + &
+ G%IdyCu(I,j)*((CS%dy2h(i,j)*str_xx(i,j)) - (CS%dy2h(i+1,j)*str_xx(i+1,j)))) * &
G%IareaCu(I,j)) / (h_u(I,j) + h_neglect)
enddo ; enddo
@@ -1763,8 +1763,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent.
do J=Jsq,Jeq ; do i=is,ie
- diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - CS%dy2q(I,J)*str_xy(I,J)) - &
- G%IdxCv(i,J)*(CS%dx2h(i,j)*str_xx(i,j) - CS%dx2h(i,j+1)*str_xx(i,j+1))) * &
+ diffv(i,J,k) = ((G%IdyCv(i,J)*((CS%dy2q(I-1,J)*str_xy(I-1,J)) - (CS%dy2q(I,J)*str_xy(I,J))) - &
+ G%IdxCv(i,J)*((CS%dx2h(i,j)*str_xx(i,j)) - (CS%dx2h(i,j+1)*str_xx(i,j+1)))) * &
G%IareaCv(i,J)) / (h_v(i,J) + h_neglect)
enddo ; enddo
@@ -1785,40 +1785,40 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v)
! This is the old formulation that includes energy diffusion
FrictWork(i,j,k) = GV%H_to_RZ * ( &
- (str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) &
- - str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) &
- + 0.25*((str_xy(I,J) * &
- ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) &
- + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) &
- + str_xy(I-1,J-1) * &
- ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) &
- + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) &
- + (str_xy(I-1,J) * &
- ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) &
- + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) &
- + str_xy(I,J-1) * &
- ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) &
- + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) )
+ ((str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) &
+ - (str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) &
+ + 0.25*(( (str_xy(I,J) * &
+ (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
+ + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
+ + (str_xy(I-1,J-1) * &
+ (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
+ + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
+ + ( (str_xy(I-1,J) * &
+ (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
+ + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
+ + (str_xy(I,J-1) * &
+ (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
+ + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
enddo ; enddo ; endif
if (CS%use_GME) then ; do j=js,je ; do i=is,ie
! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v)
! This is the old formulation that includes energy diffusion
FrictWork_GME(i,j,k) = GV%H_to_RZ * ( &
- (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) &
- - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) &
- + 0.25*((str_xy_GME(I,J) * &
- ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) &
- + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) &
- + str_xy_GME(I-1,J-1) * &
- ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) &
- + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) &
- + (str_xy_GME(I-1,J) * &
- ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) &
- + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) &
- + str_xy_GME(I,J-1) * &
- ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) &
- + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) )
+ ((str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) &
+ - (str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) &
+ + 0.25*(( (str_xy_GME(I,J) * &
+ (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
+ + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
+ + (str_xy_GME(I-1,J-1) * &
+ (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
+ + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
+ + ( (str_xy_GME(I-1,J) * &
+ (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
+ + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
+ + (str_xy_GME(I,J-1) * &
+ (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
+ + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
enddo ; enddo ; endif
! Make a similar calculation as for FrictWork above but accumulating into
@@ -1840,8 +1840,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + &
(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) )
Shear_mag_bc = sqrt(sh_xx(i,j) * sh_xx(i,j) + &
- 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + &
- (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1))))
+ 0.25*(((sh_xy(I-1,J-1)*sh_xy(I-1,J-1)) + (sh_xy(I,J)*sh_xy(I,J))) + &
+ ((sh_xy(I-1,J)*sh_xy(I-1,J)) + (sh_xy(I,J-1)*sh_xy(I,J-1)))))
if (CS%answer_date > 20190101) then
FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n
! Note the hard-coded dimensional constant in the following line that can not
@@ -1861,20 +1861,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
endif
MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( &
- ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) &
- -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) &
- + 0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * &
- ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) &
- + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) &
- + (str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * &
- ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) &
- + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) &
- + ((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * &
- ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) &
- + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) &
- + (str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * &
- ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) &
- + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) )
+ (((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) &
+ - ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) &
+ + 0.25*( (((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * &
+ (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
+ + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
+ + ((str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * &
+ (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
+ + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
+ + (((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * &
+ (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
+ + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
+ + ((str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * &
+ (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
+ + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
enddo ; enddo
endif ! MEKE%backscatter_Ro_c
@@ -2640,34 +2640,34 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
! empirically work for CS%bound_coef <~ 1.0
if (CS%biharmonic .and. CS%better_bound_Ah) then
do j=js-1,Jeq+1 ; do I=is-2,Ieq+1
- u0u(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j)) + &
- CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + &
- CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + &
- CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1)) ) )
- u0v(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1)) + &
- CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) + &
- CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + &
- CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1)) ) )
+ u0u(I,j) = ((CS%Idxdy2u(I,j)*((CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j))) + &
+ (CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) )) + &
+ (CS%Idx2dyCu(I,j)*((CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + &
+ (CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1))) )) )
+ u0v(I,j) = ((CS%Idxdy2u(I,j)*((CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1))) + &
+ (CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) + &
+ (CS%Idx2dyCu(I,j)*((CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + &
+ (CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1))) )) )
enddo ; enddo
do J=js-2,Jeq+1 ; do i=is-1,Ieq+1
- v0u(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + &
- CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + &
- CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + &
- CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) )
- v0v(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + &
- CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J)) ) + &
- CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + &
- CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) )
+ v0u(i,J) = ((CS%Idxdy2v(i,J)*((CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + &
+ (CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j))) )) + &
+ (CS%Idx2dyCv(i,J)*((CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1))) + &
+ (CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) ) ))
+ v0v(i,J) = ((CS%Idxdy2v(i,J)*((CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + &
+ (CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J))) )) + &
+ (CS%Idx2dyCv(i,J)*((CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J))) + &
+ (CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) )
enddo ; enddo
do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
denom = max( &
(CS%dy2h(i,j) * &
- (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0u(I,j) + G%IdyCu(I-1,j)*u0u(I-1,j)) + &
- CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0u(i,J) + G%IdxCv(i,J-1)*v0u(i,J-1))) * &
- max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), &
+ ((CS%DY_dxT(i,j)*((G%IdyCu(I,j)*u0u(I,j)) + (G%IdyCu(I-1,j)*u0u(I-1,j)))) + &
+ (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0u(i,J)) + (G%IdxCv(i,J-1)*v0u(i,J-1))))) * &
+ max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), &
(CS%dx2h(i,j) * &
- (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0v(I,j) + G%IdyCu(I-1,j)*u0v(I-1,j)) + &
- CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0v(i,J) + G%IdxCv(i,J-1)*v0v(i,J-1))) * &
+ ((CS%DY_dxT(i,j)*((G%IdyCu(I,j)*u0v(I,j)) + (G%IdyCu(I-1,j)*u0v(I-1,j)))) + &
+ (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0v(i,J)) + (G%IdxCv(i,J-1)*v0v(i,J-1))))) * &
max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) )
CS%Ah_Max_xx(I,J) = 0.0
if (denom > 0.0) &
@@ -2676,12 +2676,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
do J=js-1,Jeq ; do I=is-1,Ieq
denom = max( &
(CS%dx2q(I,J) * &
- (CS%DX_dyBu(I,J)*(u0u(I,j+1)*G%IdxCu(I,j+1) + u0u(I,j)*G%IdxCu(I,j)) + &
- CS%DY_dxBu(I,J)*(v0u(i+1,J)*G%IdyCv(i+1,J) + v0u(i,J)*G%IdyCv(i,J))) * &
- max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), &
+ ((CS%DX_dyBu(I,J)*((u0u(I,j+1)*G%IdxCu(I,j+1)) + (u0u(I,j)*G%IdxCu(I,j)))) + &
+ (CS%DY_dxBu(I,J)*((v0u(i+1,J)*G%IdyCv(i+1,J)) + (v0u(i,J)*G%IdyCv(i,J))))) * &
+ max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), &
(CS%dy2q(I,J) * &
- (CS%DX_dyBu(I,J)*(u0v(I,j+1)*G%IdxCu(I,j+1) + u0v(I,j)*G%IdxCu(I,j)) + &
- CS%DY_dxBu(I,J)*(v0v(i+1,J)*G%IdyCv(i+1,J) + v0v(i,J)*G%IdyCv(i,J))) * &
+ ((CS%DX_dyBu(I,J)*((u0v(I,j+1)*G%IdxCu(I,j+1)) + (u0v(I,j)*G%IdxCu(I,j)))) + &
+ (CS%DY_dxBu(I,J)*((v0v(i+1,J)*G%IdyCv(i+1,J)) + (v0v(i,J)*G%IdyCv(i,J))))) * &
max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) )
CS%Ah_Max_xy(I,J) = 0.0
if (denom > 0.0) &
@@ -2857,12 +2857,12 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2)
! Local variables
real :: recip_n2_norm ! The inverse of the squared magnitude of n1 and n2 [nondim]
! For normalizing n=(n1,n2) in case arguments are not a unit vector
- recip_n2_norm = n1**2 + n2**2
+ recip_n2_norm = (n1**2) + (n2**2)
if (recip_n2_norm > 0.) recip_n2_norm = 1. / recip_n2_norm
CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm
CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm
- CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm
- CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm
+ CS%n1n1_m_n2n2_h(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm
+ CS%n1n1_m_n2n2_q(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm
end subroutine align_aniso_tensor_to_grid
!> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any
From fc2af28edd21f95ec0bca3a9aa765a459824a64e Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Sun, 3 Mar 2024 17:16:15 -0500
Subject: [PATCH 25/30] (*)Parenthesize initialization squares for FMAs
Added parentheses to 20 sums of squares of x- and y- distances or velocity
components used for initialization in 8 modules to give rotationally consistent
solutions when fused-multiply-adds are enabled. All answers are bitwise
identical in cases without FMAs, but answers could change when FMAs are enabled.
---
src/initialization/MOM_state_initialization.F90 | 2 +-
src/tracer/advection_test_tracer.F90 | 4 ++--
src/user/Idealized_Hurricane.F90 | 14 +++++++-------
src/user/Neverworld_initialization.F90 | 8 ++++----
src/user/SCM_CVMix_tests.F90 | 2 +-
src/user/basin_builder.F90 | 6 +++---
src/user/circle_obcs_initialization.F90 | 2 +-
src/user/seamount_initialization.F90 | 2 +-
8 files changed, 20 insertions(+), 20 deletions(-)
diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90
index c18752c83d..8841ca90e6 100644
--- a/src/initialization/MOM_state_initialization.F90
+++ b/src/initialization/MOM_state_initialization.F90
@@ -1595,7 +1595,7 @@ real function my_psi(ig,jg)
x = 2.0*(G%geoLonBu(ig,jg)-G%west_lon) / G%len_lon - 1.0 ! -1<x<1
y = 2.0*(G%geoLatBu(ig,jg)-G%south_lat) / G%len_lat - 1.0 ! -1<y<1
- r = sqrt( x**2 + y**2 ) ! Circular stream function is a function of radius only
+ r = sqrt( (x**2) + (y**2) ) ! Circular stream function is a function of radius only
r = min(1.0, r) ! Flatten stream function in corners of box
my_psi = 0.5*(1.0 - cos(dpi*r))
my_psi = my_psi * (circular_max_u * G%US%m_to_L*G%len_lon*1e3 / dpi) ! len_lon is in km
diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90
index d8eb4d57fb..2684901b37 100644
--- a/src/tracer/advection_test_tracer.F90
+++ b/src/tracer/advection_test_tracer.F90
@@ -226,13 +226,13 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS
do j=js,je ; do i=is,ie
locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width
locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width
- if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0
+ if ((locx**2) + (locy**2) <= 1.0) CS%tr(i,j,k,m) = 1.0
enddo ; enddo
k=5 ! Cut cylinder
do j=js,je ; do i=is,ie
locx = (G%geoLonT(i,j)-CS%x_origin)/CS%x_width
locy = (G%geoLatT(i,j)-CS%y_origin)/CS%y_width
- if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0
+ if ((locx**2) + (locy**2) <= 1.0) CS%tr(i,j,k,m) = 1.0
if (locx>0.0 .and. abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0
enddo ; enddo
diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90
index 8028af9667..d37b1d70ae 100644
--- a/src/user/Idealized_Hurricane.F90
+++ b/src/user/Idealized_Hurricane.F90
@@ -368,7 +368,7 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx
! Implementing Holland (1980) parameteric wind profile
- radius = SQRT(XX**2 + YY**2)
+ radius = SQRT((XX**2) + (YY**2))
!/ BGR
! rkm - r converted to km for Holland prof.
@@ -451,7 +451,7 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx
dV = U10*cos(Adir-Alph) - Vocn + V_TS
! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010)
- du10 = sqrt(du**2+dv**2)
+ du10 = sqrt((du**2) + (dv**2))
if (dU10 < 11.0*US%m_s_to_L_T) then
Cd = 1.2e-3
elseif (dU10 < 20.0*US%m_s_to_L_T) then
@@ -465,8 +465,8 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx
endif
! Compute stress vector
- TX = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dU
- TY = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dV
+ TX = US%L_to_Z * CS%rho_a * Cd * sqrt((dU**2) + (dV**2)) * dU
+ TY = US%L_to_Z * CS%rho_a * Cd * sqrt((dU**2) + (dV**2)) * dV
end subroutine idealized_hurricane_wind_profile
@@ -541,7 +541,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C
!/ BR
! Calculate x position as a function of time.
xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir)
- rad = sqrt(xx**2 + CS%dy_from_center**2)
+ rad = sqrt((xx**2) + (CS%dy_from_center**2))
!/ BR
! rkm - rad converted to km for Holland prof.
! used in km due to error, correct implementation should
@@ -619,7 +619,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C
!BR
! Add a simple drag coefficient as a function of U10 |
!/----------------------------------------------------|
- du10 = sqrt(du**2+dv**2)
+ du10 = sqrt((du**2) + (dv**2))
if (dU10 < 11.0*US%m_s_to_L_T) then
Cd = 1.2e-3
elseif (dU10 < 20.0*US%m_s_to_L_T) then
@@ -641,7 +641,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C
Vocn = 0. ! sfc_state%v(i,J)
dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS
dV = U10*cos(Adir-Alph) - Vocn + V_TS
- du10=sqrt(du**2+dv**2)
+ du10 = sqrt((du**2) + (dv**2))
if (dU10 < 11.0*US%m_s_to_L_T) then
Cd = 1.2e-3
elseif (dU10 < 20.0*US%m_s_to_L_T) then
diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90
index 6885b6881a..98eca06d6b 100644
--- a/src/user/Neverworld_initialization.F90
+++ b/src/user/Neverworld_initialization.F90
@@ -157,7 +157,7 @@ real function dist_line_fixed_x(x, y, x0, y0, y1)
dx = x - x0
yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1
dy = y - yr ! =0 within y0<y<y1, =y0-y for y<y0, =y-y1 for y>y1
- dist_line_fixed_x = sqrt( dx*dx + dy*dy )
+ 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).
@@ -229,7 +229,7 @@ real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridg
real :: r ! A relative position [degrees]
real :: frac_ht ! The fractional height of the topography [nondim]
- r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point
+ r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point
r = abs( r - ring_radius) ! Pseudo-distance from a circle
frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height
circ_ridge = 1. - frac_ht ! Fractional depths (1-frac_ridge_height) .. 1
@@ -292,8 +292,8 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file,
h(i,j,k) = e0(k) - e_interface ! Nominal thickness
x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon
y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat
- r1 = sqrt((x-0.7)**2+(y-0.2)**2)
- r2 = sqrt((x-0.3)**2+(y-0.25)**2)
+ r1 = sqrt(((x-0.7)**2) + ((y-0.2)**2))
+ r2 = sqrt(((x-0.3)**2) + ((y-0.25)**2))
h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * &
(spike(r1,0.15)-spike(r2,0.15)) ! Prescribed perturbation
if (h_noise /= 0.) then
diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90
index be515f22ca..46cf6423d4 100644
--- a/src/user/SCM_CVMix_tests.F90
+++ b/src/user/SCM_CVMix_tests.F90
@@ -217,7 +217,7 @@ subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS)
enddo ; enddo
call pass_vector(forces%taux, forces%tauy, G%Domain, To_All)
- mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y)
+ mag_tau = sqrt((CS%tau_x*CS%tau_x) + (CS%tau_y*CS%tau_y))
if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie
forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / CS%Rho0 )
enddo ; enddo ; endif
diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90
index 705925a97d..c9faa0739c 100644
--- a/src/user/basin_builder.F90
+++ b/src/user/basin_builder.F90
@@ -208,7 +208,7 @@ real function dist_line_fixed_x(x, y, x0, y0, y1)
dx = x - x0
yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1
dy = y - yr ! =0 within y0<y<y1, =y0-y for y<y0, =y-y1 for y>y1
- dist_line_fixed_x = sqrt( dx*dx + dy*dy )
+ 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).
@@ -310,7 +310,7 @@ real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness
real :: r ! A relative position [degrees]
real :: frac_ht ! The fractional height of the topography [nondim]
- r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point
+ r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point
r = abs( r - ring_radius) ! Pseudo-distance from a circle
frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height
circ_conic_ridge = 1. - frac_ht ! nondim depths (1-frac_ridge_height) .. 1
@@ -329,7 +329,7 @@ real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thicknes
real :: s ! A function of the normalized position [nondim]
real :: frac_ht ! The fractional height of the topography [nondim]
- r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point
+ r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point
r = abs( r - ring_radius) ! Pseudo-distance from a circle
s = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1
frac_ht = s * ridge_height ! 0 .. frac_ridge_height
diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90
index ab9ab385de..98b5bd4705 100644
--- a/src/user/circle_obcs_initialization.F90
+++ b/src/user/circle_obcs_initialization.F90
@@ -102,7 +102,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, US, param_file,
latC = G%south_lat + 0.5*G%len_lat
lonC = G%west_lon + 0.5*G%len_lon + xOffset
do j=js,je ; do i=is,ie
- rad = sqrt((G%geoLonT(i,j)-lonC)**2+(G%geoLatT(i,j)-latC)**2)/(diskrad)
+ rad = sqrt(((G%geoLonT(i,j)-lonC)**2) + ((G%geoLatT(i,j)-latC)**2)) / diskrad
! if (rad <= 6.*diskrad) h(i,j,k) = h(i,j,k)+10.0*exp( -0.5*( rad**2 ) )
rad = min( rad, 1. ) ! Flatten outside radius of diskrad
rad = rad*(2.*asin(1.)) ! Map 0-1 to 0-pi
diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90
index 60aef08cb4..59709ecde7 100644
--- a/src/user/seamount_initialization.F90
+++ b/src/user/seamount_initialization.F90
@@ -72,7 +72,7 @@ subroutine seamount_initialize_topography( D, G, param_file, max_depth )
! Compute normalized zonal coordinates (x,y=0 at center of domain)
x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5
y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5
- D(i,j) = G%max_depth * ( 1.0 - delta * exp(-(rLx*x)**2 -(rLy*y)**2) )
+ D(i,j) = G%max_depth * ( 1.0 - delta * exp(-((rLx*x)**2) - ((rLy*y)**2)) )
enddo ; enddo
end subroutine seamount_initialize_topography
From 44f1130fc5a9238b93b6ec8d55aac67ac2ba3eff Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Sun, 3 Mar 2024 17:58:57 -0500
Subject: [PATCH 26/30] (*)Parenthesize parameterization squares for FMAs
Added parentheses to 29 sums of squares of velocity or other vector components
used in parameterizations in 9 modules to give rotationally consistent solutions
when fused-multiply-adds are enabled. All answers are bitwise identical in
cases without FMAs, but answers could change when FMAs are enabled.
---
src/diagnostics/MOM_sum_output.F90 | 2 +-
src/parameterizations/lateral/MOM_MEKE.F90 | 26 +++++++++----------
.../lateral/MOM_interface_filter.F90 | 4 +--
.../lateral/MOM_mixed_layer_restrat.F90 | 4 +--
.../vertical/MOM_CVMix_KPP.F90 | 2 +-
.../vertical/MOM_CVMix_shear.F90 | 2 +-
.../vertical/MOM_bulk_mixed_layer.F90 | 10 +++----
.../vertical/MOM_energetic_PBL.F90 | 2 +-
.../vertical/MOM_vert_friction.F90 | 8 +++---
9 files changed, 30 insertions(+), 30 deletions(-)
diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90
index fb95b79a91..736856d75f 100644
--- a/src/diagnostics/MOM_sum_output.F90
+++ b/src/diagnostics/MOM_sum_output.F90
@@ -683,7 +683,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci
tmp1(:,:,:) = 0.0
do k=1,nz ; do j=js,je ; do i=is,ie
tmp1(i,j,k) = (0.25 * KE_scale_factor * (areaTm(i,j) * h(i,j,k))) * &
- ((u(I-1,j,k)**2 + u(I,j,k)**2) + (v(i,J-1,k)**2 + v(i,J,k)**2))
+ (((u(I-1,j,k)**2) + (u(I,j,k)**2)) + ((v(i,J-1,k)**2) + (v(i,J,k)**2)))
enddo ; enddo ; enddo
KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE)
diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90
index a44eec7727..24d04b6b54 100644
--- a/src/parameterizations/lateral/MOM_MEKE.F90
+++ b/src/parameterizations/lateral/MOM_MEKE.F90
@@ -322,10 +322,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h
!$OMP parallel do default(shared)
do j=js,je ; do i=is,ie
drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * &
- ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + &
- G%areaCu(I,j)*drag_vel_u(I,j)) + &
- (G%areaCv(i,J-1)*drag_vel_v(i,J-1) + &
- G%areaCv(i,J)*drag_vel_v(i,J)) ) )
+ (((G%areaCu(I-1,j)*drag_vel_u(I-1,j)) + &
+ (G%areaCu(I,j)*drag_vel_u(I,j))) + &
+ ((G%areaCv(i,J-1)*drag_vel_v(i,J-1)) + &
+ (G%areaCv(i,J)*drag_vel_v(i,J))) ) )
enddo ; enddo
else
!$OMP parallel do default(shared)
@@ -821,8 +821,8 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m
(depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) &
/ max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) )
endif
- beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + &
- (G%dF_dy(i,j) + beta_topo_y)**2 )
+ beta = sqrt(((G%dF_dx(i,j) + beta_topo_x)**2) + &
+ ((G%dF_dy(i,j) + beta_topo_y)**2) )
if (KhCoeff*SN*I_mass(i,j)>0.) then
! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E
@@ -1001,8 +1001,8 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, &
(depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) &
/ max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) )
endif
- beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + &
- (G%dF_dy(i,j) + beta_topo_y)**2 )
+ beta = sqrt(((G%dF_dx(i,j) + beta_topo_x)**2) + &
+ ((G%dF_dy(i,j) + beta_topo_y)**2) )
else
beta = 0.
@@ -1618,9 +1618,9 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f
endif
! Calculate mean kinetic energy
- u_t = a_e*u(I,j,1)+a_w*u(I-1,j,1)
- v_t = a_n*v(i,J,1)+a_s*v(i,J-1,1)
- mke(i,j) = 0.5*( u_t*u_t + v_t*v_t )
+ u_t = (a_e*u(I,j,1)) + (a_w*u(I-1,j,1))
+ v_t = (a_n*v(i,J,1)) + (a_s*v(i,J-1,1))
+ mke(i,j) = 0.5*( (u_t*u_t) + (v_t*v_t) )
! Calculate the magnitude of the slope
slope_t = slope_x_vert_avg(I,j)*a_e+slope_x_vert_avg(I-1,j)*a_w
@@ -1632,8 +1632,8 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f
! Calculate relative vorticity
do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
- dvdx = (v(i+1,J,1)*G%dyCv(i+1,J) - v(i,J,1)*G%dyCv(i,J))
- dudy = (u(I,j+1,1)*G%dxCu(I,j+1) - u(I,j,1)*G%dxCu(I,j))
+ dvdx = ((v(i+1,J,1)*G%dyCv(i+1,J)) - (v(i,J,1)*G%dyCv(i,J)))
+ dudy = ((u(I,j+1,1)*G%dxCu(I,j+1)) - (u(I,j,1)*G%dxCu(I,j)))
! Assumed no slip
rv_z(I,J) = (2.0-G%mask2dBu(I,J)) * (dvdx - dudy) * G%IareaBu(I,J)
enddo; enddo
diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90
index 07b698e294..42782e86a1 100644
--- a/src/parameterizations/lateral/MOM_interface_filter.F90
+++ b/src/parameterizations/lateral/MOM_interface_filter.F90
@@ -123,11 +123,11 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS)
if (CS%isotropic_filter) then
!$OMP parallel do default(shared)
do j=js-hs,je+hs ; do I=is-(hs+1),ie+hs
- Lsm2_u(I,j) = (0.25*filter_strength) / (G%IdxCu(I,j)**2 + G%IdyCu(I,j)**2)
+ Lsm2_u(I,j) = (0.25*filter_strength) / ((G%IdxCu(I,j)**2) + (G%IdyCu(I,j)**2))
enddo ; enddo
!$OMP parallel do default(shared)
do J=js-(hs+1),je+hs ; do i=is-hs,ie+hs
- Lsm2_v(i,J) = (0.25*filter_strength) / (G%IdxCv(i,J)**2 + G%IdyCv(i,J)**2)
+ Lsm2_v(i,J) = (0.25*filter_strength) / ((G%IdxCv(i,J)**2) + (G%IdyCv(i,J)**2))
enddo ; enddo
else
!$OMP parallel do default(shared)
diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
index e7ada31430..7f3403aef5 100644
--- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
+++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
@@ -504,7 +504,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
! If needed, res_scaling_fac = min( ds, L_d ) / l_f
if (res_upscale) res_scaling_fac = &
- ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) &
+ ( sqrt( 0.5 * ( (G%dxCu(I,j)**2) + (G%dyCu(I,j)**2) ) ) * I_LFront ) &
* min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) )
! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star)
@@ -591,7 +591,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J)))
! If needed, res_scaling_fac = min( ds, L_d ) / l_f
if (res_upscale) res_scaling_fac = &
- ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) &
+ ( sqrt( 0.5 * ( (G%dxCv(i,J)**2) + (G%dyCv(i,J)**2) ) ) * I_LFront ) &
* min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) )
! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star)
diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90
index f480c655d7..a21b992147 100644
--- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90
@@ -1143,7 +1143,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl
Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs )
endif
- deltaU2(k) = US%L_T_to_m_s**2 * (Uk**2 + Vk**2)
+ deltaU2(k) = US%L_T_to_m_s**2 * ((Uk**2) + (Vk**2))
! pressure, temperature, and salinity for calling the equation of state
! kk+1 = surface fields
diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90
index 829318b606..46d7b98502 100644
--- a/src/parameterizations/vertical/MOM_CVMix_shear.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90
@@ -145,7 +145,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS )
endif
dz_int = 0.5*(dz(i,km1) + dz(i,k)) + GV%dZ_subroundoff
N2 = DRHO / dz_int
- S2 = US%L_to_Z**2*(DU*DU + DV*DV) / (dz_int*dz_int)
+ S2 = US%L_to_Z**2*((DU*DU) + (DV*DV)) / (dz_int*dz_int)
Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2)
! fill 3d arrays, if user asks for diagnostics
diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
index 561ace60a7..930e4f9513 100644
--- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
+++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
@@ -912,7 +912,7 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, &
do k1=min(nzc-1,nkmb),1,-1
do i=is,ie
h_orig_k1(i) = h(i,k1)
- KE_orig(i) = 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2)
+ KE_orig(i) = 0.5*h(i,k1)*((u(i,k1)**2) + (v(i,k1)**2))
uhtot(i) = h(i,k1)*u(i,k1) ; vhtot(i) = h(i,k1)*v(i,k1)
if (CS%nonBous_energetics) then
SpV0_tot(i) = SpV0(i,k1) * h(i,k1)
@@ -949,7 +949,7 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, &
dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k)
endif
KE_orig(i) = KE_orig(i) + 0.5*h_ent* &
- (u(i,k)*u(i,k) + v(i,k)*v(i,k))
+ ((u(i,k)*u(i,k)) + (v(i,k)*v(i,k)))
uhtot(i) = uhtot(i) + h_ent*u(i,k)
vhtot(i) = vhtot(i) + h_ent*v(i,k)
@@ -974,7 +974,7 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, &
endif
u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih
dKE_CA(i,k1) = dKE_CA(i,k1) + CS%bulk_Ri_convective * &
- (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2))
+ (KE_orig(i) - 0.5*h(i,k1)*((u(i,k1)**2) + (v(i,k1)**2)))
Rcv(i,k1) = Rcv_tot(i) * Ih
T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih
endif ; enddo
@@ -1407,7 +1407,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, &
if ((h_ent > 0.0) .and. (htot(i) > 0.0)) &
dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * &
((h_ent) / (htot(i)*(h_ent+htot(i)))) * &
- ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2)
+ (((uhtot(i)-u(i,k)*htot(i))**2) + ((vhtot(i)-v(i,k)*htot(i))**2))
if (h_ent > 0.0) then
htot(i) = htot(i) + h_ent
@@ -1785,7 +1785,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, &
dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) )
endif
dMKE = CS%bulk_Ri_ML * 0.5 * &
- ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2)
+ (((uhtot(i)-u(i,k)*htot(i))**2) + ((vhtot(i)-v(i,k)*htot(i))**2))
! Find the TKE that would remain if the entire layer were entrained.
kh = Idecay_len_TKE(i)*h_avail ; exp_kh = exp(-kh)
diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90
index 10907c04ed..f10e2f445d 100644
--- a/src/parameterizations/vertical/MOM_energetic_PBL.F90
+++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90
@@ -1171,7 +1171,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing,
! velocities between layer k and the layers above.
dMKE_max = (US%L_to_Z**2*GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * &
(h(k) / ((htot + h(k))*htot)) * &
- ((uhtot-u(k)*htot)**2 + (vhtot-v(k)*htot)**2)
+ (((uhtot-u(k)*htot)**2) + ((vhtot-v(k)*htot)**2))
! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be
! extracted by mixing with a finite viscosity.
MKE2_Hharm = (htot + h(k) + 2.0*h_neglect) / &
diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90
index c26ee4ac75..b1556aa42d 100644
--- a/src/parameterizations/vertical/MOM_vert_friction.F90
+++ b/src/parameterizations/vertical/MOM_vert_friction.F90
@@ -390,7 +390,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB
do k=1,nz
kp1 = MIN(k+1 , nz)
- tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1))
+ tau_u(I,j,k+1) = sqrt( (tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1)) + (tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) )
Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) )
omega_tmp = Omega_tau2x !- omega_w2x_u(I,j)
if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi
@@ -412,7 +412,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB
do k=1,nz-1
kp1 = MIN(k+1 , nz)
- tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) )
+ tau_v(i,J,k+1) = sqrt ( (tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1)) + (tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1)) )
omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) )
omega_tmp = omega_tau2x !- omega_w2x_v(i,J)
if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi
@@ -472,7 +472,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB
! diagnostics
Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG))
- tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2)
+ tau_u(I,j,k+1) = sqrt(((tauxDG_u(I,j,k+1) + tauNL_X)**2) + ((tauyDG_u(I,j,k+1) + tauNL_Y)**2))
omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X))
omega_tau2w = omega_tau2x !- omega_w2x_u(I,j)
if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi
@@ -532,7 +532,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB
! diagnostics
Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG)
- tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2)
+ tau_v(i,J,k+1) = sqrt(((tauxDG_v(i,J,k+1) + tauNL_X)**2) + ((tauyDG_v(i,J,k+1) + tauNL_Y)**2))
!omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X))
!omega_tau2w = omega_tau2x - omega_w2x_v(i,J)
if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi
From 182223c50518a9ffe1ef020d9a0dc2fc953ff182 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Tue, 30 Apr 2024 16:41:05 -0400
Subject: [PATCH 27/30] (*)Parenthesize diagnostics for FMAs
Added parentheses to 9 diagnostics of Coriolis accelerations or expressions
used in the kinetic energy budgets to give rotationally consistent solutions
when fused-multiply-adds are enabled. All answers are bitwise identical in
cases without FMAs, but answers could change when FMAs are enabled.
---
src/core/MOM_CoriolisAdv.F90 | 8 +++----
src/diagnostics/MOM_diagnostics.F90 | 24 +++++++++----------
.../lateral/MOM_hor_visc.F90 | 6 ++---
3 files changed, 19 insertions(+), 19 deletions(-)
diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90
index dce1acdd65..3cb78a1cb4 100644
--- a/src/core/MOM_CoriolisAdv.F90
+++ b/src/core/MOM_CoriolisAdv.F90
@@ -886,16 +886,16 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if (associated(AD%rv_x_u)) then
do J=Jsq,Jeq ; do i=is,ie
AD%rv_x_u(i,J,k) = - 0.25* &
- (q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + &
- q2(I,j)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J)
+ ((q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + &
+ (q2(I,j)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J)
enddo ; enddo
endif
if (associated(AD%rv_x_v)) then
do j=js,je ; do I=Isq,Ieq
AD%rv_x_v(I,j,k) = 0.25 * &
- (q2(I,j) * (vh(i+1,J,k) + vh(i,J,k)) + &
- q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j)
+ ((q2(I,j) * (vh(i+1,J,k) + vh(i,J,k))) + &
+ (q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
enddo ; enddo
endif
else
diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90
index 26af9f67d5..3376dc9be8 100644
--- a/src/diagnostics/MOM_diagnostics.F90
+++ b/src/diagnostics/MOM_diagnostics.F90
@@ -682,10 +682,10 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
mag_beta = sqrt(0.5 * ( &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
- ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
- ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ))
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + &
+ (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + &
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + &
+ (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ))
Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta)
enddo ; enddo
@@ -732,10 +732,10 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1)))
mag_beta = sqrt(0.5 * ( &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + &
- ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + &
- (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + &
- ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ))
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + &
+ (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + &
+ ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + &
+ (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ))
Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta)
enddo ; enddo
@@ -975,8 +975,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS
enddo ; enddo
do k=1,nz ; do j=js,je ; do i=is,ie
- KE(i,j,k) = ((u(I,j,k) * u(I,j,k) + u(I-1,j,k) * u(I-1,j,k)) &
- + (v(i,J,k) * v(i,J,k) + v(i,J-1,k) * v(i,J-1,k))) * 0.25
+ KE(i,j,k) = (((u(I,j,k) * u(I,j,k)) + (u(I-1,j,k) * u(I-1,j,k))) &
+ + ((v(i,J,k) * v(i,J,k)) + (v(i,J-1,k) * v(i,J-1,k)))) * 0.25
enddo ; enddo ; enddo
if (CS%id_KE > 0) call post_data(CS%id_KE, KE, CS%diag)
@@ -1301,8 +1301,8 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh)
if (IDs%id_speed > 0) then
do j=js,je ; do i=is,ie
- speed(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + &
- 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2))
+ speed(i,j) = sqrt(0.5*((sfc_state%u(I-1,j)**2) + (sfc_state%u(I,j)**2)) + &
+ 0.5*((sfc_state%v(i,J-1)**2) + (sfc_state%v(i,J)**2)))
enddo ; enddo
call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT)
endif
diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90
index 6685070682..4a794a19fe 100644
--- a/src/parameterizations/lateral/MOM_hor_visc.F90
+++ b/src/parameterizations/lateral/MOM_hor_visc.F90
@@ -1180,7 +1180,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%id_grid_Re_Kh>0) then
do j=js,je ; do i=is,ie
- KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2)
+ KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2))
grid_Kh = max(Kh(i,j), CS%min_grid_Kh)
grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) / grid_Kh
enddo ; enddo
@@ -1319,7 +1319,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%Re_Ah > 0.0) then
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2)
+ KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2))
Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j)
enddo ; enddo
endif
@@ -1353,7 +1353,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US,
if (CS%id_grid_Re_Ah>0) then
do j=js,je ; do i=is,ie
- KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2)
+ KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))**2) + ((v(i,J,k) + v(i,J-1,k))**2))
grid_Ah = max(Ah(i,j), CS%min_grid_Ah)
grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) / grid_Ah
enddo ; enddo
From e810ac5378fd3e436be2727bc5c2432c80398c82 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Sat, 4 May 2024 23:21:41 -0400
Subject: [PATCH 28/30] (*)Parenthesize tracer_advect PPM edge values
Added parentheses to 4 tracer edge value calculations used with PPM tracer
advection to give rotationally consistent solutions when fused-multiply-adds are
enabled. Although these lines may not appear to need parentheses, some
compliers appear to be putting these expressions directly into others, where the
direction of the flow seems to determine which multiplications are incorporated
into FMAs. All answers are bitwise identical in cases without FMAs, but answers
could change when FMAs are enabled.
---
src/tracer/MOM_tracer_advect.F90 | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90
index e927f2f89d..7118fdd401 100644
--- a/src/tracer/MOM_tracer_advect.F90
+++ b/src/tracer/MOM_tracer_advect.F90
@@ -540,9 +540,9 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
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 extrema and boundary 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
@@ -925,9 +925,9 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then
aL = Tc ; aR = Tc ! PCM for local extrema and boundary 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
From ffa766b4510fc308c2190652fc5cc5b545fe02bb Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Wed, 31 Jul 2024 18:06:15 -0400
Subject: [PATCH 29/30] (*)More parentheses in density_integrals for FMAs
Added parentheses around the full expressions for intz and intp in 10 more
lines in 4 generic density integral routines (int_density_dz_generic_pcm,
int_density_dz_generic_ppm, int_spec_vol_dp_generic_pcm and
int_spec_vol_dp_generic_plm) in the MOM_density_integrals module so that
non-Boussinesq cases will be rotationally invariant when fused-multiply-adds are
enabled. Although this might not seem to do anything, these parentheses do
matter if these expressions are in-lined in the sums where they are used a few
lines later. The analogous parentheses had previously been added to
int_density_dz_generic_plm. All answers are bitwise identical in cases without
FMAs, but answers could change with FMAs.
---
src/core/MOM_density_integrals.F90 | 40 +++++++++++++++---------------
1 file changed, 20 insertions(+), 20 deletions(-)
diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90
index 5b50c5b57d..bf6b2f6fef 100644
--- a/src/core/MOM_density_integrals.F90
+++ b/src/core/MOM_density_integrals.F90
@@ -279,16 +279,16 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
if (use_rho_ref) then
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)) + &
+ 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)))
+ 12.0*r15(pos+3)) ))
enddo
else
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)) + &
+ intz(m) = (G_e*dz_x(m,i)*(C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + &
32.0*(r15(pos+2)+r15(pos+4)) + &
- 12.0*r15(pos+3)) - rho_ref )
+ 12.0*r15(pos+3)) - rho_ref ))
enddo
endif
! Use Boole's rule to integrate the bottom pressure anomaly values in x.
@@ -347,13 +347,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
do m=2,4
pos = i*15+(m-2)*5
if (use_rho_ref) then
- intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+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)))
+ 12.0*r15(pos+3)) ))
else
- intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + &
+ intz(m) = (G_e*dz_y(m,i)*(C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + &
32.0*(r15(pos+2)+r15(pos+4)) + &
- 12.0*r15(pos+3)) - rho_ref )
+ 12.0*r15(pos+3)) - rho_ref ))
endif
enddo
! Use Boole's rule to integrate the values.
@@ -1054,9 +1054,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
do m=2,4
pos = i*15+(m-2)*5
! Use Boole's rule to estimate the pressure anomaly change.
- intz(m) = G_e*dz_x(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+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)) )
+ 12.0*r15(pos+3)) ))
enddo ! m
intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
@@ -1158,9 +1158,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
do m=2,4
! Use Boole's rule to estimate the pressure anomaly change.
pos = i*15+(m-2)*5
- intz(m) = G_e*dz_y(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+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)) )
+ 12.0*r15(pos+3)) ))
enddo ! m
intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1)
@@ -1406,8 +1406,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
! Use Boole's rule to estimate the interface height anomaly change.
do m=2,4
pos = i*15+(m-2)*5
- intp(m) = dp_x(m,I)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + &
- 12.0*a15(pos+3)))
+ intp(m) = (dp_x(m,I)*( C1_90*(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)) + &
@@ -1461,8 +1461,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
! Use Boole's rule to estimate the interface height anomaly change.
do m=2,4
pos = i*15+(m-2)*5
- intp(m) = dp_y(m,i)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + &
- 12.0*a15(pos+3)))
+ intp(m) = (dp_y(m,i)*( C1_90*(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 y.
inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + &
@@ -1652,8 +1652,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
! Use Boole's rule to estimate the interface height anomaly change.
! The integrals at the ends of the segment are already known.
pos = I*15+(m-2)*5
- intp(m) = dp_90(m,I)*((7.0*(a15(pos+1)+a15(pos+5)) + &
- 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3))
+ intp(m) = (dp_90(m,I)*((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))) + &
@@ -1714,8 +1714,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref,
! Use Boole's rule to estimate the interface height anomaly change.
! The integrals at the ends of the segment are already known.
pos = i*15+(m-2)*5
- intp(m) = dp_90(m,i) * ((7.0*(a15(pos+1)+a15(pos+5)) + &
- 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3))
+ intp(m) = (dp_90(m,i) * ((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))) + &
From fd82861e3b095ea18b0f5d8dc36559d8870b1820 Mon Sep 17 00:00:00 2001
From: Robert Hallberg <Robert.Hallberg@noaa.gov>
Date: Fri, 2 Aug 2024 08:03:12 -0400
Subject: [PATCH 30/30] (*)Add parentheses in end_value_h4 for FMAs
Added parentheses to prevent FMAs in 4 expressions in end_value_h4 that rely
on exact vertical symmetry in order to get the cancellations that are necessary
to pass the vertical remapping unit testing. Before this change, the MOM6
unit-testing was failing when FMAs are enabled, but with it the unit-testing is
passing even when FMAs are enabled. All answers are bitwise identical in cases
without FMAs, but answers could change with FMAs.
---
src/ALE/regrid_edge_values.F90 | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90
index 0814c6a907..8aaeb12654 100644
--- a/src/ALE/regrid_edge_values.F90
+++ b/src/ALE/regrid_edge_values.F90
@@ -748,10 +748,10 @@ subroutine end_value_h4(dz, u, Csys)
Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234)
Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34)
- Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3))
- Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3))
- Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3))
- Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3))
+ Csys(1) = ((u(1) + (Wt(1,1) * (u(2)-u(1)))) + (Wt(2,1) * (u(3)-u(2)))) + (Wt(3,1) * (u(4)-u(3)))
+ Csys(2) = ((Wt(1,2) * (u(2)-u(1))) + (Wt(2,2) * (u(3)-u(2)))) + (Wt(3,2) * (u(4)-u(3)))
+ Csys(3) = ((Wt(1,3) * (u(2)-u(1))) + (Wt(2,3) * (u(3)-u(2)))) + (Wt(3,3) * (u(4)-u(3)))
+ Csys(4) = ((Wt(1,4) * (u(2)-u(1))) + (Wt(2,4) * (u(3)-u(2)))) + (Wt(3,4) * (u(4)-u(3)))
! endif ! End of non-uniform layer thickness branch.