From 8d05f394d31f63d08970d7c4899447d70b63f1b1 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Mon, 8 Jul 2024 13:12:30 -0600 Subject: [PATCH 01/31] initialize cpl_scalar field when created --- config_src/drivers/nuopc_cap/mom_cap.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index d2dcf96067..eab4191308 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -2370,6 +2370,11 @@ subroutine SetScalarField(field, rc) ungriddedLBound=(/1/), ungriddedUBound=(/scalar_field_count/), gridToFieldMap=(/2/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + end subroutine SetScalarField end subroutine MOM_RealizeFields From 6628dbff5eb8220f4f2303534222f2b6b71c07dd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 29 Feb 2024 20:20:41 -0500 Subject: [PATCH 02/31] (*)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 Date: Thu, 29 Feb 2024 14:00:52 -0500 Subject: [PATCH 03/31] (*)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 Date: Thu, 29 Feb 2024 20:43:14 -0500 Subject: [PATCH 04/31] (*)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 Date: Thu, 29 Feb 2024 22:00:29 -0500 Subject: [PATCH 05/31] (*)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 Date: Thu, 29 Feb 2024 22:53:14 -0500 Subject: [PATCH 06/31] (*)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 Date: Mon, 4 Mar 2024 08:46:26 -0500 Subject: [PATCH 07/31] (*)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 Date: Fri, 1 Mar 2024 06:50:32 -0500 Subject: [PATCH 08/31] (*)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 Date: Fri, 1 Mar 2024 07:04:47 -0500 Subject: [PATCH 09/31] (*)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 Date: Fri, 1 Mar 2024 07:05:09 -0500 Subject: [PATCH 10/31] (*)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 Date: Fri, 1 Mar 2024 07:05:30 -0500 Subject: [PATCH 11/31] (*)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 Date: Fri, 1 Mar 2024 07:27:53 -0500 Subject: [PATCH 12/31] (*)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 Date: Fri, 1 Mar 2024 07:34:09 -0500 Subject: [PATCH 13/31] (*)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 Date: Fri, 1 Mar 2024 08:46:11 -0500 Subject: [PATCH 14/31] +(*)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 Date: Fri, 1 Mar 2024 12:34:14 -0500 Subject: [PATCH 15/31] (*)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 Date: Fri, 1 Mar 2024 12:34:41 -0500 Subject: [PATCH 16/31] (*)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 Date: Fri, 1 Mar 2024 12:35:01 -0500 Subject: [PATCH 17/31] (*)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 Date: Fri, 1 Mar 2024 12:35:40 -0500 Subject: [PATCH 18/31] (*)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 Date: Fri, 1 Mar 2024 12:36:40 -0500 Subject: [PATCH 19/31] (*)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 Date: Fri, 1 Mar 2024 12:45:21 -0500 Subject: [PATCH 20/31] (*)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 Date: Fri, 1 Mar 2024 12:50:54 -0500 Subject: [PATCH 21/31] (*)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 Date: Fri, 1 Mar 2024 18:59:11 -0500 Subject: [PATCH 22/31] (*)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 Date: Fri, 1 Mar 2024 18:59:28 -0500 Subject: [PATCH 23/31] (*)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 Date: Sat, 2 Mar 2024 08:11:04 -0500 Subject: [PATCH 24/31] (*)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 Date: Thu, 18 Apr 2024 19:21:34 -0400 Subject: [PATCH 25/31] (*)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 Date: Sun, 3 Mar 2024 17:16:15 -0500 Subject: [PATCH 26/31] (*)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 ! -10.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 y0y1 - 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 y0y1 - 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 Date: Sun, 3 Mar 2024 17:58:57 -0500 Subject: [PATCH 27/31] (*)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 Date: Tue, 30 Apr 2024 16:41:05 -0400 Subject: [PATCH 28/31] (*)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 Date: Sat, 4 May 2024 23:21:41 -0400 Subject: [PATCH 29/31] (*)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 Date: Wed, 31 Jul 2024 18:06:15 -0400 Subject: [PATCH 30/31] (*)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 Date: Fri, 2 Aug 2024 08:03:12 -0400 Subject: [PATCH 31/31] (*)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.