From 50b850d6198e7c37d0c45fb1380b1a123fcb7f40 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 13 Jul 2018 17:20:28 -0400 Subject: [PATCH 01/37] Corrected two openMP directives Corrected openMP directives in two places, so MOM6 now compiles with openMP enabled. The variable local_strain had recently been added to horizontal_viscosity, but it was omitted from an openMP directive. A recent change had left an incomplete openMP directive around KPP_get_BLD in diabatic. All solutions (at least without openMP on) are bitwise identical. --- .../lateral/MOM_hor_visc.F90 | 22 +++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 3 ++- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2a166bac09..3be015faa4 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -316,17 +316,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, ! Toggle whether to use a Laplacian viscosity derived from MEKE use_MEKE_Ku = associated(MEKE%Ku) -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,CS,G,GV,u,v,is,js,ie,je,h, & -!$OMP rescale_Kh,VarMix,h_neglect,h_neglect3, & -!$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,apply_OBC,OBC,diffv, & -!$OMP find_FrictWork,FrictWork,use_MEKE_Ku,MEKE, & -!$OMP mod_Leith, legacy_bound) & -!$OMP private(u0, v0, sh_xx, str_xx, visc_bound_rem, & -!$OMP sh_xy, str_xy, Ah, Kh, AhSm, KhSm, dvdx, dudy, & -!$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv, h_u, h_v, & -!$OMP vort_xy,vort_xy_dx,vort_xy_dy,Vort_mag,AhLth,KhLth, & -!$OMP div_xx, div_xx_dx, div_xx_dy, & -!$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) + !$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,CS,G,GV,u,v,is,js,ie,je,h, & + !$OMP rescale_Kh,VarMix,h_neglect,h_neglect3, & + !$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,apply_OBC,OBC,diffv, & + !$OMP find_FrictWork,FrictWork,use_MEKE_Ku,MEKE, & + !$OMP mod_Leith, legacy_bound) & + !$OMP private(u0, v0, sh_xx, str_xx, visc_bound_rem, & + !$OMP sh_xy, str_xy, Ah, Kh, AhSm, KhSm, dvdx, dudy, & + !$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv, h_u, h_v, & + !$OMP vort_xy,vort_xy_dx,vort_xy_dy,Vort_mag,AhLth,KhLth, & + !$OMP div_xx, div_xx_dx, div_xx_dy, local_strain, & + !$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) do k=1,nz ! The following are the forms of the horizontal tension and horizontal diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8a16e79ecd..188ba9c8f3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -610,10 +610,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call KPP_calculate(CS%KPP_CSp, G, GV, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) if (associated(Hml)) then + !$OMP parallel default(shared) call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + !$OMP end parallel call pass_var(Hml, G%domain, halo=1) endif From ad3961c2dfed77b5525dbf5ce67ba0b1b15bda2c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 15 Jul 2018 12:07:37 -0800 Subject: [PATCH 02/37] Time-filter on oblique OBCs. - also set default OBC vorticity, strain to freeslip. --- src/core/MOM_open_boundary.F90 | 101 +++++++++++++++++++++++++-------- 1 file changed, 78 insertions(+), 23 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 38a945233b..3c9343d1c4 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -156,6 +156,8 @@ module MOM_open_boundary !! for normal velocity real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff !! for normal velocity + real, pointer, dimension(:,:,:) :: cff_normal=>NULL() !< The denominator for oblique radiation + !! for normal velocity real, pointer, dimension(:,:,:) :: nudged_normal_vel=>NULL() !< The layer velocity normal to the OB segment !! that values should be nudged towards (m s-1). real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment @@ -237,6 +239,7 @@ module MOM_open_boundary type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: rx_normal => NULL() !< Array storage for restarts real, pointer, dimension(:,:,:) :: ry_normal => NULL() !< Array storage for restarts + real, pointer, dimension(:,:,:) :: cff_normal => NULL() !< Array storage for restarts real :: silly_h !< A silly value of thickness outside of the domain that !! can be used to test the independence of the OBCs to !! this external data, in m. @@ -315,7 +318,7 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & "If true, sets the normal gradient of tangential velocity to\n"// & "zero in the relative vorticity on open boundaries. This cannot\n"// & - "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & "If true, uses the external values of tangential velocity\n"// & "in the relative vorticity on open boundaries. This cannot\n"// & @@ -339,7 +342,7 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & "If true, sets the normal gradient of tangential velocity to\n"// & "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & - "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + "be true if another OBC_XXX_STRAIN option is True.", default=.true.) call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & "If true, sets the normal gradient of tangential velocity to\n"// & "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & @@ -431,7 +434,7 @@ subroutine open_boundary_config(G, param_file, OBC) ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & call initialize_segment_data(G, OBC, param_file) - if (open_boundary_query(OBC, apply_Flather_OBC=.true.)) then + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & "The maximum magnitude of the baroclinic radiation \n"//& "velocity (or speed of characteristics). This is only \n"//& @@ -1499,6 +1502,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation real :: ry_new, ry_avg ! coefficients for radiation + real :: cff_new, cff_avg ! denominator in oblique real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() real, parameter :: eps = 1.0e-20 @@ -1540,6 +1544,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) do j=segment%HI%jsd,segment%HI%jed segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) enddo enddo elseif (segment%is_N_or_S .and. segment%oblique) then @@ -1548,6 +1553,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) do i=segment%HI%isd,segment%HI%ied segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) enddo enddo endif @@ -1588,11 +1594,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = dhdt*dhdx - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) - segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I-1,j,k)) - & - (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff,max(dhdt*dhdy,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I-1,j,k) endif @@ -1698,11 +1714,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = dhdt*dhdx - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) - segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I+1,j,k)) - & - (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff,max(dhdt*dhdy,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I+1,j,k) endif @@ -1809,11 +1835,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = dhdt*dhdy - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) - segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J-1,k)) - & - (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff,max(dhdt*dhdx,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J-1,k) endif @@ -1920,11 +1956,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = dhdt*dhdy - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) - segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J+1,k)) - & - (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff,max(dhdt*dhdx,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J+1,k) endif @@ -2286,6 +2332,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif endif @@ -2321,6 +2368,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif endif @@ -2341,6 +2389,7 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%eta)) deallocate(segment%eta) if (associated (segment%rx_normal)) deallocate(segment%rx_normal) if (associated (segment%ry_normal)) deallocate(segment%ry_normal) + if (associated (segment%cff_normal)) deallocate(segment%cff_normal) if (associated (segment%normal_vel)) deallocate(segment%normal_vel) if (associated (segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) if (associated (segment%normal_trans)) deallocate(segment%normal_trans) @@ -3473,6 +3522,12 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) vd = var_desc("ry_normal","m s-1", "Normal Phase Speed for NS OBCs",'v','L') call register_restart_field(OBC_CS%ry_normal, vd, .true., restart_CSp) endif + if (OBC_CS%oblique_BCs_exist_globally) then + allocate(OBC_CS%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) + OBC_CS%cff_normal(:,:,:) = 0.0 + vd = var_desc("cff_normal","m s-1", "denominator for oblique OBCs",'q','L') + call register_restart_field(OBC_CS%cff_normal, vd, .true., restart_CSp) + endif end subroutine open_boundary_register_restarts From 12410a1ec688b88fb34bf2e6b3c39eaa3e315397 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 18 Jul 2018 16:15:58 -0800 Subject: [PATCH 03/37] Fix nudging with oblique OBCs. --- src/core/MOM_open_boundary.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3c9343d1c4..259714e984 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1613,7 +1613,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(I,j,k) = u_new(I-1,j,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdx < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1733,7 +1734,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(I,j,k) = u_new(I+1,j,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdx < 0.0) then + ! dhdt gets set to 0. on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1854,7 +1856,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(i,J,k) = v_new(i,J-1,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdy < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1975,7 +1978,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(i,J,k) = v_new(i,J+1,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdy < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out From e0ca46b0728d14a7fffd6d661a74c5199a7c310e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 20 Jul 2018 17:47:16 -0400 Subject: [PATCH 04/37] +Added stress_mag to ice_ocean_boundary_type Added a new element, stress_mag, with the time-mean of the magnitude of the wind stresses at tracer points, to the ice_ocean_boundary_type. It is not yet being used, so all answers are bitwise identical. --- config_src/coupled_driver/MOM_surface_forcing.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 19a0ddbf86..02b54daefe 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -166,6 +166,7 @@ module MOM_surface_forcing real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip (kg/m2/s) real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff (kg/m2/s) real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff (kg/m2/s) + real, pointer, dimension(:,:) :: stress_mag =>NULL() !< The time-mean magnitude of the stress on the ocean (Pa) real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs (m/s) real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs(m2/m2) real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) From 8d794eff5ccd57d26d481b7bceea6f097c90c99a Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 1 Aug 2018 10:51:18 -0800 Subject: [PATCH 05/37] Adding OBLIQUE_TAN and OBLIQUE_GRAD options. --- src/core/MOM_open_boundary.F90 | 454 +++++++++++++++++++++++++++++++-- 1 file changed, 438 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 259714e984..de8c2fe174 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -112,6 +112,10 @@ module MOM_open_boundary logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to !! dudv and dvdx. logical :: oblique !< Oblique waves supported at radiation boundary. + logical :: oblique_tan !< If true, 2D radiation boundary conditions are applied to + !! tangential flows. + logical :: oblique_grad !< If true, 2D radiation boundary conditions are applied to + !! dudv and dvdx. logical :: nudged !< Optional supplement to radiation boundary. logical :: nudged_tan !< Optional supplement to nudge tangential velocity. logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity. @@ -151,7 +155,11 @@ module MOM_open_boundary !! the OB segment (m s-1). real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment (m). real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the - !! segment (m s-1) + !! segment (s-1) + real, pointer, dimension(:,:,:) :: grad_tan=>NULL() !< The gradient of the tangential flow along the + !! segment (s-1) + real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along the + !! segment (m-1 s-1) real, pointer, dimension(:,:,:) :: rx_normal=>NULL() !< The rx_old_u value for radiation coeff !! for normal velocity real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff @@ -397,6 +405,8 @@ subroutine open_boundary_config(G, param_file, OBC) OBC%segment(l)%radiation_tan = .false. OBC%segment(l)%radiation_grad = .false. OBC%segment(l)%oblique = .false. + OBC%segment(l)%oblique_tan = .false. + OBC%segment(l)%oblique_grad = .false. OBC%segment(l)%nudged = .false. OBC%segment(l)%nudged_tan = .false. OBC%segment(l)%nudged_grad = .false. @@ -818,6 +828,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) OBC%segment(l_seg)%open = .true. OBC%oblique_BCs_exist_globally = .true. OBC%open_u_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'OBLIQUE_TAN') then + OBC%segment(l_seg)%oblique = .true. + OBC%segment(l_seg)%oblique_tan = .true. + OBC%oblique_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'OBLIQUE_GRAD') then + OBC%segment(l_seg)%oblique = .true. + OBC%segment(l_seg)%oblique_grad = .true. elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_u_BCs_exist_globally = .true. @@ -871,6 +888,10 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) OBC%segment(l_seg)%Je_obc = Je_obc call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) + if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc:\n"//& + "Orlanski and Oblique OBC options cannot be used together on one segment.") + end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly @@ -931,6 +952,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) OBC%segment(l_seg)%open = .true. OBC%oblique_BCs_exist_globally = .true. OBC%open_v_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'OBLIQUE_TAN') then + OBC%segment(l_seg)%oblique = .true. + OBC%segment(l_seg)%oblique_tan = .true. + OBC%oblique_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'OBLIQUE_GRAD') then + OBC%segment(l_seg)%oblique = .true. + OBC%segment(l_seg)%oblique_grad = .true. elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_v_BCs_exist_globally = .true. @@ -984,6 +1012,10 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) OBC%segment(l_seg)%Je_obc = J_obc call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) + if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & + call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc:\n"//& + "Orlanski and Oblique OBC options cannot be used together on one segment.") + end subroutine setup_v_point_obc !> Parse an OBC_SEGMENT_%%% string @@ -1505,6 +1537,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real :: cff_new, cff_avg ! denominator in oblique real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() + real, pointer, dimension(:,:,:) :: cff_tangential=>NULL() real, parameter :: eps = 1.0e-20 type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, nz, n @@ -1606,6 +1639,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) @@ -1642,7 +1677,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1672,7 +1708,77 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) & + + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1683,6 +1789,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) endif endif @@ -1727,6 +1835,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) @@ -1758,12 +1868,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(I+1,J,k) + rx_avg*v_new(I+2,J,k)) / (1.0+rx_avg) + segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1793,7 +1904,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1805,6 +1917,77 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif deallocate(rx_tangential) endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) & + + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif endif if (segment%direction == OBC_DIRECTION_N) then @@ -1849,6 +2032,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) @@ -1857,7 +2042,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then ! dhdt gets set to 0 on inflow in oblique case - if (dhdt*dhdx <= 0.0) then + if (dhdt*dhdy <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1885,7 +2070,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1909,13 +2095,14 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) ! else ! rx_avg = 0.0 ! endif - segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I-1,j,k))*G%IdyBu(I,J-1) + & + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_grad) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -1927,9 +2114,79 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif deallocate(rx_tangential) endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + min(ry_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) & + + rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & + (max(ry_avg,0.0)*segment%grad_gradient(I,2,k) + min(ry_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif endif - if (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB if (J>G%HI%JecB) cycle @@ -1971,6 +2228,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) @@ -1979,7 +2238,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then ! dhdt gets set to 0 on inflow in oblique case - if (dhdt*dhdx <= 0.0) then + if (dhdt*dhdy <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -2007,7 +2266,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -2037,7 +2297,77 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - if (rx_tangential(I,J,k) < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + min(ry_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) & + + rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & + (max(ry_avg,0.0)*segment%grad_gradient(i,2,k) + min(ry_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -2048,6 +2378,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) endif endif enddo @@ -2144,6 +2476,24 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_tan(j,1,k) = (vvel(i-1,J,k)-vvel(i-1,J-1,k)) * G%mask2dT(i-1,j) + segment%grad_tan(j,2,k) = (vvel(i,J,k)-vvel(i,J-1,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%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-1,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,j) + enddo + enddo + endif else ! western segment I=segment%HI%isdB do k=1,G%ke @@ -2152,6 +2502,24 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_tan(j,1,k) = (vvel(i+2,J,k)-vvel(i+2,J-1,k)) * G%mask2dT(i+2,j) + segment%grad_tan(j,2,k) = (vvel(i+1,J,k)-vvel(i+1,J-1,k)) * G%mask2dT(i+1,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%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) + 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) + enddo + enddo + endif endif elseif (segment%is_N_or_S) then if (segment%direction == OBC_DIRECTION_N) then @@ -2162,6 +2530,24 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_tan(i,1,k) = (uvel(I,j-1,k)-uvel(I-1,j-1,k)) * G%mask2dT(i,j-1) + segment%grad_tan(i,2,k) = (uvel(I,j,k)-uvel(I-1,j,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%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%IdxBu(I,J-2)) - & + (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdxBu(I-1,J-2)) * G%mask2dCv(I,j-1) + 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) + enddo + enddo + endif else ! south segment J=segment%HI%jsdB do k=1,G%ke @@ -2170,6 +2556,24 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_tan(i,1,k) = (uvel(I,j+2,k)-uvel(I-1,j+2,k)) * G%mask2dT(i,j+2) + segment%grad_tan(i,2,k) = (uvel(I,j+1,k)-uvel(I-1,j+1,k)) * G%mask2dT(i,j+1) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%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%IdxBu(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%IdxBu(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 endif endif @@ -2329,7 +2733,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged_grad) then allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 endif - if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then @@ -2338,6 +2743,12 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif + if (segment%oblique_tan) then + allocate(segment%grad_tan(jsd:jed,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + endif + if (segment%oblique_grad) then + allocate(segment%grad_gradient(jsd:jed,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 + endif endif if (segment%is_N_or_S) then @@ -2365,7 +2776,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged_grad) then allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 endif - if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then @@ -2374,6 +2786,12 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif + if (segment%oblique_tan) then + allocate(segment%grad_tan(isd:ied,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + endif + if (segment%oblique_grad) then + allocate(segment%grad_gradient(isd:ied,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 + endif endif end subroutine allocate_OBC_segment_data @@ -2394,12 +2812,16 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%rx_normal)) deallocate(segment%rx_normal) if (associated (segment%ry_normal)) deallocate(segment%ry_normal) if (associated (segment%cff_normal)) deallocate(segment%cff_normal) + if (associated (segment%grad_normal)) deallocate(segment%grad_normal) + if (associated (segment%grad_tan)) deallocate(segment%grad_tan) + if (associated (segment%grad_gradient)) deallocate(segment%grad_gradient) if (associated (segment%normal_vel)) deallocate(segment%normal_vel) if (associated (segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) if (associated (segment%normal_trans)) deallocate(segment%normal_trans) if (associated (segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel) if (associated (segment%tangential_vel)) deallocate(segment%tangential_vel) if (associated (segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel) + if (associated (segment%nudged_tangential_grad)) deallocate(segment%nudged_tangential_grad) if (associated (segment%tangential_grad)) deallocate(segment%tangential_grad) if (associated (segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) From c95d513194bade848ba75a460bd63ba5a6c9cc5b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Aug 2018 03:18:31 -0400 Subject: [PATCH 06/37] +Use stress_mag to set ustar Added code to use IOB%stress_mag to set ustar if is allocated. The code to set stress_mag in SIS2 is equivalent to that in MOM6, so the answers are currently unchanged if this new option is used. Also rearranged the code setting the wind stresses, ustar, and other forcing fields so they are more logically grouped. All answers are bitwise identical in test cases, but there are new options to allow the sea-ice or coupler to set ustar differently. --- .../coupled_driver/MOM_surface_forcing.F90 | 133 ++++++++++-------- 1 file changed, 72 insertions(+), 61 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 02b54daefe..693a200c18 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -324,7 +324,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - if (CS%allow_flux_adjustments) then fluxes%heat_added(:,:)=0.0 fluxes%salt_flux_added(:,:)=0.0 @@ -576,7 +575,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. - + ! Local variables real, dimension(SZIB_(G),SZJB_(G)) :: & taux_at_q, & ! Zonal wind stresses at q points (Pa) tauy_at_q ! Meridional wind stresses at q points (Pa) @@ -611,7 +610,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 i0 = is - isc_bnd ; j0 = js - jsc_bnd - Irho0 = 1.0/CS%Rho0 + Irho0 = 1.0/CS%Rho0 ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. @@ -638,6 +637,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) if ( (associated(IOB%area_berg) .and. (.not. associated(forces%area_berg))) .or. & (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) + if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -672,41 +672,16 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger + + ! Set surface momentum stress related fields as a function of staggering. if (wind_stagger == BGRID_NE) then ! This is necessary to fill in the halo points. taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - endif - - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (associated(IOB%area_berg)) & - forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) - - if (associated(IOB%mass_berg)) & - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - - if (associated(IOB%ice_rigidity)) & - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) - - if (wind_stagger == BGRID_NE) then + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - endif - - enddo ; enddo - - ! surface momentum stress related fields as function of staggering - if (wind_stagger == BGRID_NE) then + enddo ; enddo if (G%symmetric) & call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) @@ -727,25 +702,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo - ! ustar is required for the bulk mixed layer formulation. The background value - ! of 0.02 Pa is a relatively small value intended to give reasonable behavior - ! in regions of very weak winds. - + elseif (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + ! obtain fluxes from IOB; note the staggering of indices do j=js,je ; do i=is,ie - tau_mag = 0.0 ; gustiness = CS%gust_const - if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier enddo ; enddo - - elseif (wind_stagger == AGRID) then call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, & stagger=AGRID, halo=1) @@ -765,25 +729,61 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo + else ! C-grid wind stresses. do j=js,je ; do i=is,ie - gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier enddo ; enddo - - else ! C-grid wind stresses. if (G%symmetric) & call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) + endif ! endif for wind stress fields + ! Set surface friction velocity directly or as a function of staggering. + ! ustar is required for the bulk mixed layer formulation and other turbulent mixing + ! parametizations. The background gustiness (for example with a relatively small value + ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. + if (associated(IOB%stress_mag)) then + do j=js,je ; do i=is,ie + gustiness = CS%gust_const + !### SIMPLIFY THE TREATMENT OF GUSTINESS! + if (CS%read_gust_2d) then + if ((wind_stagger == CGRID_NE) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == BGRID_NE) .and. & + (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + gustiness = CS%gust(i,j) + endif + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) + enddo ; enddo + elseif (wind_stagger == BGRID_NE) then + do j=js,je ; do i=is,ie + tau_mag = 0.0 ; gustiness = CS%gust_const + if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) + enddo ; enddo + elseif (wind_stagger == AGRID) then + do j=js,je ; do i=is,ie + gustiness = CS%gust_const + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + enddo ; enddo + else ! C-grid wind stresses. do j=js,je ; do i=is,ie - taux2 = 0.0 + taux2 = 0.0 ; tauy2 = 0.0 if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - - tauy2 = 0.0 if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) @@ -794,11 +794,22 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo + endif ! endif for wind friction velocity fields - endif ! endif for wind related fields + ! Obtain optional ice-berg related fluxes from the IOB type: + if (associated(IOB%area_berg)) then ; do j=js,je ; do i=is,ie + forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + enddo ; enddo ; endif - ! sea ice related dynamic fields + if (associated(IOB%mass_berg)) then ; do j=js,je ; do i=is,ie + forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + enddo ; enddo ; endif + + ! Obtain sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then + do j=js,je ; do i=is,ie + rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + enddo ; enddo call pass_var(rigidity_at_h, G%Domain, halo=1) do I=is-1,ie ; do j=js,je forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & From e1762f57d14e4f01ce2bc9b63fa42818163618fc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Aug 2018 12:49:41 -0400 Subject: [PATCH 07/37] +Added extract_IOB_stresses Added a new subroutine, extract_IOB_stresses, to obtain the wind stresses and friction velocities from the ice-ocean-boundary type into simple arrays that are provided as optional arguments. All answers are bitwise identical. --- .../coupled_driver/MOM_surface_forcing.F90 | 209 ++++++++++++++++++ 1 file changed, 209 insertions(+) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 693a200c18..996455d26c 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -856,6 +856,215 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) call cpu_clock_end(id_clock_forcing) end subroutine convert_IOB_to_forces + +!> This subroutine extracts the wind stresses and related fields like ustar from an +!! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign +!! conventions, and putting the fields into arrays with MOM-standard sized halos. +subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, ustar, gustless_ustar) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: taux !< The zonal wind stresses on a C-grid, in Pa. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: tauy !< The meridional wind stresses on a C-grid, in Pa. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: ustar !< The surface friction velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: gustless_ustar !< The surface friction velocity without + !! any contributions from gustiness, in m s-1. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G)) :: & + taux_at_u ! Zonal wind stresses at u points (Pa) + real, dimension(SZI_(G),SZJB_(G)) :: & + tauy_at_v ! Meridional wind stresses at V points (Pa) + real, dimension(SZIB_(G),SZJB_(G)) :: & + taux_at_q, & ! Zonal wind stresses at q points (Pa) + tauy_at_q ! Meridional wind stresses at q points (Pa) + + real, dimension(SZI_(G),SZJ_(G)) :: & + taux_at_h, & ! Zonal wind stresses at h points (Pa) + tauy_at_h ! Meridional wind stresses at h points (Pa) + + real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) + real :: Irho0 ! inverse of the mean density in (m^3/kg) + real :: taux2, tauy2 ! squared wind stresses (Pa^2) + real :: tau_mag ! magnitude of the wind stress (Pa) + + logical :: do_ustar, do_gustless + integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + Irho0 = 1.0/CS%Rho0 + + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + + wind_stagger = CS%wind_stagger + if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & + (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger + + ! Set surface momentum stress related fields as a function of staggering. + if (present(taux) .or. present(tauy) .or. & + ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + if (wind_stagger == BGRID_NE) then + ! This is necessary to fill in the halo points. + taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + if (G%symmetric) & + call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) + + if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + taux(I,j) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) + enddo ; enddo ; endif + + if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + tauy(i,J) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) + enddo ; enddo ; endif + + elseif (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, & + stagger=AGRID, halo=1) + + if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + taux(I,j) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j)) + enddo ; enddo ; endif + + if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + tauy(i,J) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1)) + enddo ; enddo ; endif + + else ! C-grid wind stresses. + do j=js,je ; do i=is,ie + if (associated(IOB%u_flux)) taux_at_u(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_v(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + if (G%symmetric) & + call fill_symmetric_edges(taux_at_u, tauy_at_v, G%Domain) + call pass_vector(taux_at_u, tauy_at_v, G%Domain, halo=1) + + if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + taux(I,j) = G%mask2dCu(I,j)*taux_at_u(I,j) + enddo ; enddo ; endif + + if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + tauy(i,J) = G%mask2dCv(i,J)*tauy_at_v(i,J) + enddo ; enddo ; endif + + endif ! endif for extracting wind stress fields with various staggerings + endif + + if (do_ustar .or. do_gustless) then + ! Set surface friction velocity directly or as a function of staggering. + ! ustar is required for the bulk mixed layer formulation and other turbulent mixing + ! parametizations. The background gustiness (for example with a relatively small value + ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. + if (associated(IOB%stress_mag)) then + if (do_ustar) then ; do j=js,je ; do i=is,ie + gustiness = CS%gust_const + !### SIMPLIFY THE TREATMENT OF GUSTINESS! + if (CS%read_gust_2d) then + if ((wind_stagger == CGRID_NE) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == BGRID_NE) .and. & + (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + gustiness = CS%gust(i,j) + endif + ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) + enddo ; enddo ; endif + if (do_gustless) then ; do j=js,je ; do i=is,ie + gustless_ustar(i,j) = sqrt(Irho0*IOB%stress_mag(i-i0,j-j0)) + enddo ; enddo ; endif + elseif (wind_stagger == BGRID_NE) then + do j=js,je ; do i=is,ie + tau_mag = 0.0 ; gustiness = CS%gust_const + if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + enddo ; enddo + elseif (wind_stagger == AGRID) then + do j=js,je ; do i=is,ie + tau_mag = G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) + gustiness = CS%gust_const + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + enddo ; enddo + else ! C-grid wind stresses. + 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) & + taux2 = (G%mask2dCu(I-1,j)*taux_at_u(I-1,j)**2 + & + G%mask2dCu(I,j)*taux_at_u(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + tauy2 = (G%mask2dCv(i,J-1)*tauy_at_v(i,J-1)**2 + & + G%mask2dCv(i,J)*tauy_at_v(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + tau_mag = sqrt(taux2 + tauy2) + + gustiness = CS%gust_const + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + enddo ; enddo + endif ! endif for wind friction velocity fields + endif + +end subroutine extract_IOB_stresses + + !> Adds thermodynamic flux adjustments obtained via data_override !! Component name is 'OCN' !! Available adjustments are: From 4b859d488ef76ec0a1fdc9b4cbfabdc2d100288d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Aug 2018 18:53:49 -0400 Subject: [PATCH 08/37] Always set G%Domain_aux G%Domain_aux points to a non-symmetric MOM6 domain. It had previously only been set if G%Domain is symmetric, but was otherwise not associated. Now if G%domain is itself non-symmetric, G%domain_aux simply points back to G%domain. G%domain_aux can now be used more widely without causing problems. All answers are bitwise identical. --- src/core/MOM.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c554e4f92e..ce23880906 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2135,8 +2135,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. - if (CS%debug .or. G%symmetric) & + if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) + else ; G%Domain_aux => G%Domain ; endif ! Copy common variables from the vertical grid to the horizontal grid. ! Consider removing this later? G%ke = GV%ke ; G%g_Earth = GV%g_Earth @@ -2165,8 +2166,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_grid_end(G) ; deallocate(G) G => CS%G - if (CS%debug .or. CS%G%symmetric) & + if (CS%debug .or. CS%G%symmetric) then call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) + else ; CS%G%Domain_aux => CS%G%Domain ;endif G%ke = GV%ke ; G%g_Earth = GV%g_Earth endif From 7507e2d8d373f5562876de47b829bf07ebb5c868 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Aug 2018 18:54:32 -0400 Subject: [PATCH 09/37] Set stresses via extract_IOB_stresses Replaced the code setting the wind stresses in code_IOB_to_forces with a call to extract_IOB_stresses. Also streamlined extract_IOB_stresses to avoid extra unnecessary communications. All answers are bitwise identical. --- .../coupled_driver/MOM_surface_forcing.F90 | 198 ++++-------------- 1 file changed, 35 insertions(+), 163 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 996455d26c..c963670ee3 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -669,132 +669,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) endif forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. - wind_stagger = CS%wind_stagger - if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & - (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger - - ! Set surface momentum stress related fields as a function of staggering. - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & - G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & - G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo ; enddo - - elseif (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo - call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, & - stagger=AGRID, halo=1) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & - G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & - (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & - G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & - (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo ; enddo - - else ! C-grid wind stresses. - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo - if (G%symmetric) & - call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) - endif ! endif for wind stress fields - - ! Set surface friction velocity directly or as a function of staggering. - ! ustar is required for the bulk mixed layer formulation and other turbulent mixing - ! parametizations. The background gustiness (for example with a relatively small value - ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. - if (associated(IOB%stress_mag)) then - do j=js,je ; do i=is,ie - gustiness = CS%gust_const - !### SIMPLIFY THE TREATMENT OF GUSTINESS! - if (CS%read_gust_2d) then - if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & - ((wind_stagger == BGRID_NE) .and. & - (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & - gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) - enddo ; enddo - elseif (wind_stagger == BGRID_NE) then - do j=js,je ; do i=is,ie - tau_mag = 0.0 ; gustiness = CS%gust_const - if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo ; enddo - elseif (wind_stagger == AGRID) then - do j=js,je ; do i=is,ie - gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - enddo ; enddo - else ! C-grid wind stresses. - 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) & - 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)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - - if (CS%read_gust_2d) then - forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) - else - forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) - endif - enddo ; enddo - endif ! endif for wind friction velocity fields + ! Set the wind stresses and ustar. + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux=forces%taux, tauy=forces%tauy, & + ustar=forces%ustar, tau_halo=1) ! Obtain optional ice-berg related fluxes from the IOB type: if (associated(IOB%area_berg)) then ; do j=js,je ; do i=is,ie @@ -860,7 +737,8 @@ end subroutine convert_IOB_to_forces !> This subroutine extracts the wind stresses and related fields like ustar from an !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. -subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, ustar, gustless_ustar) +subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, ustar, & + gustless_ustar, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -871,23 +749,24 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(out) :: taux !< The zonal wind stresses on a C-grid, in Pa. + optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid, in Pa. real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(out) :: tauy !< The meridional wind stresses on a C-grid, in Pa. + optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid, in Pa. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(out) :: ustar !< The surface friction velocity, in m s-1. + optional, intent(inout) :: ustar !< The surface friction velocity, in m s-1. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: gustless_ustar !< The surface friction velocity without !! any contributions from gustiness, in m s-1. + integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables - real, dimension(SZIB_(G),SZJ_(G)) :: & - taux_at_u ! Zonal wind stresses at u points (Pa) - real, dimension(SZI_(G),SZJB_(G)) :: & - tauy_at_v ! Meridional wind stresses at V points (Pa) - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: & + taux_at_u ! Zonal wind stresses at u points (Pa) with non-symmetric memory + real, dimension(SZI_(G),SZJ_(G)) :: & + tauy_at_v ! Meridional wind stresses at V points (Pa) with non-symmetric memory + real, dimension(SZI_(G),SZJ_(G)) :: & + taux_at_q, & ! Zonal wind stresses at q points (Pa) with non-symmetric memory + tauy_at_q ! Meridional wind stresses at q points (Pa) with non-symmetric memory real, dimension(SZI_(G),SZJ_(G)) :: & taux_at_h, & ! Zonal wind stresses at h points (Pa) @@ -900,20 +779,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta logical :: do_ustar, do_gustless integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - - call cpu_clock_begin(id_clock_forcing) + integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo - isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) - jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + halo = 0 ; if (present(tau_halo)) halo = tau_halo is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 - i0 = is - isc_bnd ; j0 = js - jsc_bnd + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo + Isqh = G%IscB-halo ; Ieqh = G%IecB+halo ; Jsqh = G%JscB-halo ; Jeqh = G%JecB+halo + i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) Irho0 = 1.0/CS%Rho0 @@ -934,18 +806,16 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier enddo ; enddo - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) + call pass_vector(taux_at_q, tauy_at_q, G%Domain_aux, stagger=BGRID_NE, halo=1+halo) - if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo ; endif - if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & @@ -960,17 +830,20 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier enddo ; enddo - call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, & - stagger=AGRID, halo=1) + if (halo == 0) then + call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) + else + call pass_vector(taux_at_h, tauy_at_h, G%Domain, stagger=AGRID, halo=1+halo) + endif - if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif - if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & @@ -978,19 +851,18 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta enddo ; enddo ; endif else ! C-grid wind stresses. + taux_at_u(:,:) = 0.0 ; tauy_at_v(:,:) = 0.0 do j=js,je ; do i=is,ie if (associated(IOB%u_flux)) taux_at_u(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_v(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier enddo ; enddo - if (G%symmetric) & - call fill_symmetric_edges(taux_at_u, tauy_at_v, G%Domain) - call pass_vector(taux_at_u, tauy_at_v, G%Domain, halo=1) + call pass_vector(taux_at_u, tauy_at_v, G%Domain_aux, halo=1+halo) - if (present(taux)) then ; do j=js,je ; do I=Isq,Ieq + if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = G%mask2dCu(I,j)*taux_at_u(I,j) enddo ; enddo ; endif - if (present(tauy)) then ; do J=Jsq,Jeq ; do i=is,ie + if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = G%mask2dCv(i,J)*tauy_at_v(i,J) enddo ; enddo ; endif From 0d1894635bedf9275905debea05bdb0ea762a73a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Aug 2018 19:13:53 -0400 Subject: [PATCH 10/37] Code cleanup in MOM_surface_forcing.F90 Code cleanup in MOM_surface_forcing.F90 to reduce memory use. All answers are bitwise identical. --- .../coupled_driver/MOM_surface_forcing.F90 | 95 +++++++------------ 1 file changed, 34 insertions(+), 61 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index c963670ee3..a341a34b42 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -576,25 +576,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) !! previous call to surface_forcing_init. ! Local variables - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h ! Meridional wind stresses at h points (Pa) + rigidity_at_h ! Ice rigidity at tracer points (m3 s-1) - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) real :: mass_ice ! mass of sea ice at a face (kg/m^2) real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -610,8 +599,6 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 i0 = is - isc_bnd ; j0 = js - jsc_bnd - Irho0 = 1.0/CS%Rho0 - ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then @@ -761,16 +748,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_u ! Zonal wind stresses at u points (Pa) with non-symmetric memory - real, dimension(SZI_(G),SZJ_(G)) :: & - tauy_at_v ! Meridional wind stresses at V points (Pa) with non-symmetric memory - real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) with non-symmetric memory - tauy_at_q ! Meridional wind stresses at q points (Pa) with non-symmetric memory - + taux_in ! Zonal wind stresses (in Pa) at u, h, or q points, depending on the value of + ! wind_stagger, always with non-symmetric memory to permit array reuse. real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h ! Meridional wind stresses at h points (Pa) + tauy_in ! Meridional wind stresses (in Pa) at v, h, or q points, depending on the value of + ! wind_stagger, always with non-symmetric memory to permit array reuse. real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) real :: Irho0 ! inverse of the mean density in (m^3/kg) @@ -798,72 +780,63 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + + ! This is necessary to fill in the halo points. + taux_in(:,:) = 0.0 ; tauy_in(:,:) = 0.0 + ! Obtain stress from IOB; note that the staggering locations of taux_in and tauy_in depend + ! on the values of wind_stagger, so the case-sensitive index convention is not used here. + do j=js,je ; do i=is,ie + if (associated(IOB%u_flux)) taux_in(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_in(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo - call pass_vector(taux_at_q, tauy_at_q, G%Domain_aux, stagger=BGRID_NE, halo=1+halo) + call pass_vector(taux_in, tauy_in, G%Domain_aux, stagger=BGRID_NE, halo=1+halo) if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & + taux(I,j) = (G%mask2dBu(I,J)*taux_in(I,J) + G%mask2dBu(I,J-1)*taux_in(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & + tauy(i,J) = (G%mask2dBu(I,J)*tauy_in(I,J) + G%mask2dBu(I-1,J)*tauy_in(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo ; endif elseif (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo if (halo == 0) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) + call pass_vector(taux_in, tauy_in, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) else - call pass_vector(taux_at_h, tauy_at_h, G%Domain, stagger=AGRID, halo=1+halo) + call pass_vector(taux_in, tauy_in, G%Domain, stagger=AGRID, halo=1+halo) endif if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & + taux(I,j) = (G%mask2dT(i,j)*taux_in(i,j) + G%mask2dT(i+1,j)*taux_in(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & + tauy(i,J) = (G%mask2dT(i,j)*tauy_in(i,j) + G%mask2dT(i,J+1)*tauy_in(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif else ! C-grid wind stresses. - taux_at_u(:,:) = 0.0 ; tauy_at_v(:,:) = 0.0 - do j=js,je ; do i=is,ie - if (associated(IOB%u_flux)) taux_at_u(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_v(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - enddo ; enddo - call pass_vector(taux_at_u, tauy_at_v, G%Domain_aux, halo=1+halo) + call pass_vector(taux_in, tauy_in, G%Domain_aux, halo=1+halo) if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh - taux(I,j) = G%mask2dCu(I,j)*taux_at_u(I,j) + taux(I,j) = G%mask2dCu(I,j)*taux_in(I,j) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh - tauy(i,J) = G%mask2dCv(i,J)*tauy_at_v(i,J) + tauy(i,J) = G%mask2dCv(i,J)*tauy_in(i,J) enddo ; enddo ; endif endif ! endif for extracting wind stress fields with various staggerings @@ -896,10 +869,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in(I,J)**2 + tauy_in(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_in(I-1,J-1)**2 + tauy_in(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_in(I,J-1)**2 + tauy_in(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_in(I-1,J)**2 + tauy_in(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 @@ -908,7 +881,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta enddo ; enddo elseif (wind_stagger == AGRID) then do j=js,je ; do i=is,ie - tau_mag = G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) + tau_mag = G%mask2dT(i,j) * sqrt(taux_in(i,j)**2 + tauy_in(i,j)**2) gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) @@ -918,11 +891,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta 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) & - taux2 = (G%mask2dCu(I-1,j)*taux_at_u(I-1,j)**2 + & - G%mask2dCu(I,j)*taux_at_u(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + taux2 = (G%mask2dCu(I-1,j)*taux_in(I-1,j)**2 + & + G%mask2dCu(I,j)*taux_in(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*tauy_at_v(i,J-1)**2 + & - G%mask2dCv(i,J)*tauy_at_v(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + tauy2 = (G%mask2dCv(i,J-1)*tauy_in(i,J-1)**2 + & + G%mask2dCv(i,J)*tauy_in(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) tau_mag = sqrt(taux2 + tauy2) gustiness = CS%gust_const From b15f514126eeb3a9d03a4627a3f9db2c123bfdc8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Aug 2018 15:04:55 -0400 Subject: [PATCH 11/37] Set ustar in fluxes via extract_IOB_stresses Set ustar in fluxes via extract_IOB_stresses, using sub-optimal expressions involving division by mean density rather than multiplication by its reciprocal to reproduce what had been done in set_derived_forcing_fields. All answers are bitwise identical. --- .../coupled_driver/MOM_surface_forcing.F90 | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index a341a34b42..71e7f611aa 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -544,6 +544,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & endif + ! Set the wind stresses and ustar. + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, ustar=fluxes%ustar, & + gustless_ustar=fluxes%ustar_gustless) + elseif (associated(fluxes%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, ustar=fluxes%ustar) + elseif (associated(fluxes%ustar_gustless)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, gustless_ustar=fluxes%ustar_gustless) + endif + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & coupler_type_initialized(IOB%fluxes)) & call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) @@ -862,7 +872,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(Irho0*IOB%stress_mag(i-i0,j-j0)) + gustless_ustar(i,j) = sqrt(IOB%stress_mag(i-i0,j-j0) / CS%Rho0) +!### Change to: +! gustless_ustar(i,j) = sqrt(Irho0 * IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif elseif (wind_stagger == BGRID_NE) then do j=js,je ; do i=is,ie @@ -877,7 +889,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) enddo ; enddo elseif (wind_stagger == AGRID) then do j=js,je ; do i=is,ie @@ -885,7 +899,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) enddo ; enddo else ! C-grid wind stresses. do j=js,je ; do i=is,ie @@ -902,7 +918,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux, tauy, usta if (CS%read_gust_2d) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) enddo ; enddo endif ! endif for wind friction velocity fields endif From f20c3f1e04b822af8a97489a850b766a54f7da2c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Aug 2018 15:05:23 -0400 Subject: [PATCH 12/37] +Changed interface to forcing_accumulate Turned forces into an optional argument to forcing_accumulate and changed the order of the list of arguments. Forces is no longer needed when the pressure and ustar fields are properly set in the temporary fluxes array. The forces argument is now omitted from the call to forcing_accumulate in update_ocean_model, and the call to set_derived_forcing_fields has been eliminated. All answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 13 ++--- src/core/MOM_forcing_type.F90 | 51 +++++++++++++------ 2 files changed, 40 insertions(+), 24 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index a09a5bfe29..dde127b146 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -505,9 +505,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid, skip_pres=.true.) - #ifdef _USE_GENERIC_TRACER call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes @@ -516,6 +513,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%fluxes%fluxes_used = .false. OS%fluxes%dt_buoy_accum = dt_coupling else + ! The previous fluxes have not been used yet, so translate the input fluxes + ! into a temporary type and then accumulate them in about 20 lines. OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & @@ -536,16 +535,15 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) + call forcing_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types - ! (e.g., ustar) are time-averages must be copied back to the forces type. + ! (now just ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) #ifdef _USE_GENERIC_TRACER call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average #endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%use_waves) then @@ -573,8 +571,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) - thermo_does_span_coupling = (OS%thermo_spans_coupling .and. & - (OS%dt_therm > 1.5*dt_coupling)) + thermo_does_span_coupling = (OS%thermo_spans_coupling .and. (OS%dt_therm > 1.5*dt_coupling)) if (thermo_does_span_coupling) then dt_therm = dt_coupling * floor(OS%dt_therm / dt_coupling + 0.001) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9486967b40..4235c2a82f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1742,15 +1742,15 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use end subroutine register_forcing_type_diags !> Accumulate the forcing over time steps -subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) - type(forcing), intent(in) :: flux_tmp !< A temporary structure with current - !!thermodynamic forcing fields - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged - !! thermodynamic forcing fields - real, intent(in) :: dt !< The elapsed time since the last call to this subroutine, in s - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes +subroutine forcing_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !! thermodynamic forcing fields + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + real, intent(in) :: dt !< The elapsed time since the last call to this subroutine, in s + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes + type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -1774,15 +1774,29 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) wt2 = 1.0 - wt1 ! = dt / (fluxes%dt_buoy_accum + dt) fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + dt - ! Copy over the pressure fields. - do j=js,je ; do i=is,ie - fluxes%p_surf(i,j) = forces%p_surf(i,j) - fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) - enddo ; enddo + ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing + ! type or from the temporary fluxes type. + if (present(forces)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) + fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + enddo ; enddo + endif ! Average the water, heat, and salt fluxes, and ustar. do j=js,je ; do i=is,ie - fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) +!### Replace the expression for ustar_gustless with this one... +! fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) @@ -1922,9 +1936,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, Rho0) !! as used to calculate ustar. real :: taux2, tauy2 ! Squared wind stress components, in Pa^2. + real :: Irho0 ! Inverse of the mean density in (m^3/kg) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Irho0 = 1.0/Rho0 + if (associated(forces%taux) .and. associated(forces%tauy) .and. & associated(fluxes%ustar_gustless)) then do j=js,je ; do i=is,ie @@ -1940,13 +1957,15 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, Rho0) (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) / Rho0) +!### Change to: +! fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) enddo ; enddo endif end subroutine set_derived_forcing_fields -!> This subroutine calculates determines the net mass source to th eocean from +!> This subroutine calculates determines the net mass source to the ocean from !! a (thermodynamic) forcing type and stores it in a mech_forcing type. subroutine set_net_mass_forcing(fluxes, forces, G) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields From c02b134bd143f8ce595312ee50ae6fbd8ba92bb8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Aug 2018 19:04:08 -0400 Subject: [PATCH 13/37] (+)Restored the interface to forcing_accumulate Restored the interface to forcing_accumulate to what it had been previously, and added a new subroutine, fluxes_accumulate, that uses the newer interface, with the new forcing_accumulate calling fluxes_accumulate. This new interface is now in use in update_ocean_model. In addition, set_net_mass_forcing now calls get_net_mass_forcing to eliminate duplicated code. All answers are bitwise identical, and slightly older public interfaces have been restored to avoid code conflicts with MOM6 drivers outside of coupled_driver. --- config_src/coupled_driver/ocean_model_MOM.F90 | 13 ++- src/core/MOM_forcing_type.F90 | 92 +++++++++++++------ 2 files changed, 69 insertions(+), 36 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index dde127b146..a2d87c6624 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -23,11 +23,9 @@ module ocean_model_mod use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : allocate_forcing_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type +use MOM_forcing_type, only : fluxes_accumulate, get_net_mass_forcing +use MOM_forcing_type, only : copy_back_forcing_fields use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type @@ -535,7 +533,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - call forcing_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) + call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types ! (now just ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) @@ -544,7 +542,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average #endif endif - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + if (associated(OS%forces%net_mass_src)) & + call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) if (OS%use_waves) then call Update_Surface_Waves(OS%grid, OS%GV, OS%time, ocean_coupling_time_step, OS%waves) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4235c2a82f..6aa0487439 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -26,11 +26,13 @@ module MOM_forcing_type public extractFluxes1d, extractFluxes2d, optics_type public MOM_forcing_chksum, MOM_mech_forcing_chksum -public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, forcing_accumulate +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d +public forcing_accumulate, fluxes_accumulate public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type public copy_common_forcing_fields, allocate_mech_forcing, deallocate_mech_forcing -public set_derived_forcing_fields, copy_back_forcing_fields, set_net_mass_forcing +public set_derived_forcing_fields, copy_back_forcing_fields +public set_net_mass_forcing, get_net_mass_forcing !> Structure that contains pointers to the boundary forcing used to drive the !! liquid ocean simulated by MOM. @@ -1741,8 +1743,29 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use end subroutine register_forcing_type_diags -!> Accumulate the forcing over time steps -subroutine forcing_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) +!> Accumulate the forcing over time steps, taking input from a mechanical forcing type +!! and a temporary forcing-flux type. +subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !!thermodynamic forcing fields + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + real, intent(in) :: dt !< The elapsed time since the last call to this subroutine, in s + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes + + ! This subroutine copies mechancal forcing from flux_tmp to fluxes and + ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, + ! and increments the amount of time over which the buoyancy forcing should be + ! applied, all via a call to fluxes accumulate. + + call fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) + +end subroutine forcing_accumulate + +!> Accumulate the thermodynamic fluxes over time steps +subroutine fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) type(forcing), intent(in) :: flux_tmp !< A temporary structure with current !! thermodynamic forcing fields type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged @@ -1880,7 +1903,7 @@ subroutine forcing_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) call coupler_type_increment_data(flux_tmp%tr_fluxes, fluxes%tr_fluxes, & scale_factor=wt2, scale_prev=wt1) -end subroutine forcing_accumulate +end subroutine fluxes_accumulate !> This subroutine copies the computational domains of common forcing fields !! from a mech_forcing type to a (thermodynamic) forcing type. @@ -1970,34 +1993,45 @@ end subroutine set_derived_forcing_fields subroutine set_net_mass_forcing(fluxes, forces, G) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(ocean_grid_type), intent(in) :: G !< grid type + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + + if (associated(forces%net_mass_src)) & + call get_net_mass_forcing(fluxes, G, forces%net_mass_src) + +end subroutine set_net_mass_forcing + +!> This subroutine calculates determines the net mass source to the ocean from +!! a (thermodynamic) forcing type and stores it in a provided array. +subroutine get_net_mass_forcing(fluxes, G, net_mass_src) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_mass_src !< The net mass flux of water into the ocean + !! in kg m-2 s-1. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (associated(forces%net_mass_src)) then - forces%net_mass_src(:,:) = 0.0 - if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%lprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%fprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%vprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%lrunoff(i,j) - enddo ; enddo ; endif - if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%frunoff(i,j) - enddo ; enddo ; endif - if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%evap(i,j) - enddo ; enddo ; endif - endif - -end subroutine set_net_mass_forcing + net_mass_src(:,:) = 0.0 + if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%fprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%vprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) + enddo ; enddo ; endif + +end subroutine get_net_mass_forcing !> This subroutine copies the computational domains of common forcing fields !! from a mech_forcing type to a (thermodynamic) forcing type. From 13f9303ced1ace1a33397b3ce3af81ac6439cbeb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Aug 2018 11:23:37 -0400 Subject: [PATCH 14/37] +Added optional arguments to convert_IOB_to_forces Added two new optional arguments to convert_IOB_to_forces to allow it to do a running time average of ustar, matching what had previously been done only for ustar in the fluxes type. Also added the new element dt_force_accum to the mech_forcing type to enable this averaging. All answers are bitwise identical, although there are new optional arguments to a publicly visible routine. --- .../coupled_driver/MOM_surface_forcing.F90 | 40 +++++++++++++++++-- src/core/MOM_forcing_type.F90 | 9 ++--- 2 files changed, 40 insertions(+), 9 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 71e7f611aa..a4cd1162d7 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -573,7 +573,7 @@ end subroutine convert_IOB_to_fluxes !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! mechanical forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS, dt_forcing, reset_avg) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -584,15 +584,22 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. + real, optional, intent(in) :: dt_forcing !< A time interval over which to apply the + !! current value of ustar as a weighted running + !! average, in s, or if 0 do not average ustar. + !! Missing is equivalent to 0. + logical, optional, intent(in) :: reset_avg !< If true, reset the time average. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h ! Ice rigidity at tracer points (m3 s-1) + rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) + ustar_tmp ! A temporary array of ustars. real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) real :: mass_ice ! mass of sea ice at a face (kg/m^2) real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) + real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer @@ -645,6 +652,23 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + ! Set the weights for forcing fields that use running time averages. + if (present(reset_avg)) then ; if (reset_avg) forces%dt_force_accum = 0.0 ; endif + wt1 = 0.0 ; wt2 = 1.0 + if (present(dt_forcing)) then + if ((forces%dt_force_accum > 0.0) .and. (dt_forcing > 0.0)) then + wt1 = forces%dt_force_accum / (forces%dt_force_accum + dt_forcing) + wt2 = 1.0 - wt1 + endif + if (dt_forcing > 0.0) then + forces%dt_force_accum = max(forces%dt_force_accum, 0.0) + dt_forcing + else + forces%dt_force_accum = 0.0 ! Reset the averaging time interval. + endif + else + forces%dt_force_accum = 0.0 ! Reset the averaging time interval. + endif + ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -667,8 +691,16 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. ! Set the wind stresses and ustar. - call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=forces%ustar, tau_halo=1) + if (wt1 <= 0.0) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux=forces%taux, tauy=forces%tauy, & + ustar=forces%ustar, tau_halo=1) + else + call extract_IOB_stresses(IOB, index_bounds, Time, G, CS, taux=forces%taux, tauy=forces%tauy, & + ustar=ustar_tmp, tau_halo=1) + do j=js,je ; do i=is,ie + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + enddo ; enddo + endif ! Obtain optional ice-berg related fluxes from the IOB type: if (associated(IOB%area_berg)) then ; do j=js,je ; do i=is,ie diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 6aa0487439..1df0fe1473 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -42,8 +42,6 @@ module MOM_forcing_type !! MESO_surface_forcing.F90, which is a special case of solo_driver/MOM_surface_forcing.F90. type, public :: forcing - ! Pointers in this module should be initialized to NULL. - ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & ustar => NULL(), & !< surface friction velocity scale (m/s) @@ -154,11 +152,10 @@ module MOM_forcing_type logical :: fluxes_used = .true. !< If true, all of the heat, salt, and mass !! fluxes have been applied to the ocean. - real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes + real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes !! should be applied, in s. If negative, this forcing !! type variable has not yet been inialized. - ! heat capacity real :: C_p !< heat capacity of seawater ( J/(K kg) ). !! C_p is is the same value as in thermovar_ptrs_type. @@ -169,7 +166,7 @@ module MOM_forcing_type !! This is not a convenient convention, but imposed on MOM6 by the coupler. ! For internal error tracking - integer :: num_msg = 0 !< Number of messages issues about excessive SW penetration + integer :: num_msg = 0 !< Number of messages issued about excessive SW penetration integer :: max_msg = 2 !< Maximum number of messages to issue about excessive SW penetration end type forcing @@ -213,6 +210,8 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points (m3/s) rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points (m3/s) + real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes + !! have been averaged, in s. logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level From 5f253d4ed91889250d04992386eafce5a6dd530c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Aug 2018 11:23:55 -0400 Subject: [PATCH 15/37] Consolidate dynamic & thermodynamic forcing setup Consolidated the code in update_ocean_model that set up the dynamic and thermodynamic forcing structures. This takes advantage of the recently added optional arguments to convert_IOB_to_forces to do time averaging of ustar. All answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 104 ++++++++---------- 1 file changed, 47 insertions(+), 57 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index a2d87c6624..d1a15bc496 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -241,11 +241,12 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "ocean_model_init" ! This module's name. - character(len=48) :: stagger - integer :: secs, days + character(len=48) :: stagger ! A string indicating the staggering locations for the + ! surface velocities returned to the coupler. +! integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters logical :: use_temperature - type(time_type) :: dt_geometric, dt_savedays, dt_from_base +! type(time_type) :: dt_geometric, dt_savedays, dt_from_base call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then @@ -430,7 +431,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! start of a call to step_MOM. integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. - real :: weight ! Flux accumulation weight + real :: weight ! Flux accumulation weight of the current fluxes. real :: dt_coupling ! The coupling time step in seconds. integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. @@ -444,13 +445,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! multiple dynamic timesteps. logical :: do_dyn ! If true, step the ocean dynamics and transport. logical :: do_thermo ! If true, step the ocean thermodynamics. - logical :: step_thermo ! If true, take a thermodynamic step. - integer :: secs, days + logical :: step_thermo ! If true, take a thermodynamic step. + integer :: secs, days ! Integer number of days and seconds in the timestep. integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") call get_time(Ocean_coupling_time_step, secs, days) dt_coupling = 86400.0*real(days) + real(secs) +!### dt_coupling = time_type_to_real(Ocean_coupling_time_step) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -472,75 +474,59 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - ! Translate Ice_ocean_boundary into fluxes. + ! Translate Ice_ocean_boundary into fluxes and forces. call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & index_bnds(3), index_bnds(4)) - weight = 1.0 - - call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp) + if (do_dyn) then + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, OS%grid, & + OS%forcing_CSp, dt_forcing=dt_coupling, reset_avg=OS%fluxes%fluxes_used) + if (OS%use_ice_shelf) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + if (OS%icebergs_alter_ocean) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + endif - if (OS%fluxes%fluxes_used) then - if (do_thermo) & + if (do_thermo) then + if (OS%fluxes%fluxes_used) then call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, & - OS%restore_salinity, OS%restore_temp) + OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, & + OS%restore_temp) - ! Add ice shelf fluxes - if (OS%use_ice_shelf) then - if (do_thermo) & + ! Add ice shelf fluxes + if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) - if (do_dyn) & - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) - endif - if (OS%icebergs_alter_ocean) then - if (do_dyn) & - call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - if (do_thermo) & + if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - endif + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes + call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) !here weight=1, so just saving the current fluxes #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling - else - ! The previous fluxes have not been used yet, so translate the input fluxes - ! into a temporary type and then accumulate them in about 20 lines. - OS%flux_tmp%C_p = OS%fluxes%C_p - if (do_thermo) & + ! Indicate that there are new unused fluxes. + OS%fluxes%fluxes_used = .false. + OS%fluxes%dt_buoy_accum = dt_coupling + else + ! The previous fluxes have not been used yet, so translate the input fluxes + ! into a temporary type and then accumulate them in about 20 lines. + OS%flux_tmp%C_p = OS%fluxes%C_p call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, & + OS%restore_temp) - if (OS%use_ice_shelf) then - if (do_thermo) & + if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) - if (do_dyn) & - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) - endif - if (OS%icebergs_alter_ocean) then - if (do_dyn) & - call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - if (do_thermo) & + if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - endif - - call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) - ! Some of the fields that exist in both the forcing and mech_forcing types - ! (now just ustar) are time-averages must be copied back to the forces type. - call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) #ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average #endif + endif endif if (associated(OS%forces%net_mass_src)) & call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) @@ -613,6 +599,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. + !### Use ticks here for more precision. + !Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & @@ -621,6 +609,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif t_elapsed_seg = t_elapsed_seg + dt_dyn + !### Use ticks here for more precision. + ! Time2 = Time1 + real_to_time_type(t_elapsed_seg) Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) enddo endif From c54a25aca7e36cde16ca8dff7e9c6c94dfd3def6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Aug 2018 12:46:40 -0400 Subject: [PATCH 16/37] (*)Allow for fractional second coupling timesteps By replacing several set_time calls that quantize times at whole numbers of seconds with calls to real_to_time_type, the MOM6 coupled timesteps can now be integer numbers of ticks (fractional seconds). This could change answers if MOM6 were called with non-integer second timesteps, but in all existing test cases this is not the case, so the answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 25 ++++++------------- config_src/solo_driver/MOM_driver.F90 | 11 ++++---- 2 files changed, 14 insertions(+), 22 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index d1a15bc496..e3fd612c70 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -37,10 +37,10 @@ module ocean_model_mod use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_time_manager, only : time_type, operator(>), operator(+), operator(-) +use MOM_time_manager, only : operator(*), operator(/), operator(/=) +use MOM_time_manager, only : operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : real_to_time_type, time_type_to_real use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_variables, only : surface @@ -243,10 +243,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) character(len=40) :: mdl = "ocean_model_init" ! This module's name. character(len=48) :: stagger ! A string indicating the staggering locations for the ! surface velocities returned to the coupler. -! integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters - logical :: use_temperature -! type(time_type) :: dt_geometric, dt_savedays, dt_from_base + logical :: use_temperature ! If true, temperature and salinity are state variables. call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then @@ -446,13 +444,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & logical :: do_dyn ! If true, step the ocean dynamics and transport. logical :: do_thermo ! If true, step the ocean thermodynamics. logical :: step_thermo ! If true, take a thermodynamic step. - integer :: secs, days ! Integer number of days and seconds in the timestep. integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") - call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) -!### dt_coupling = time_type_to_real(Ocean_coupling_time_step) + dt_coupling = time_type_to_real(Ocean_coupling_time_step) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -599,9 +594,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - !### Use ticks here for more precision. - !Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -609,9 +602,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif t_elapsed_seg = t_elapsed_seg + dt_dyn - !### Use ticks here for more precision. - ! Time2 = Time1 + real_to_time_type(t_elapsed_seg) - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + real_to_time_type(t_elapsed_seg) enddo endif diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 61c3f4a509..7dd60403c2 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -48,7 +48,8 @@ program MOM_main use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real + use MOM_time_manager, only : time_type, set_date, set_time, get_date + use MOM_time_manager, only : real_to_time_type, time_type_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name @@ -356,7 +357,7 @@ program MOM_main endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = set_time(int(floor(dt_forcing+0.5))) + Time_step_ocean = real_to_time_type(dt_forcing) elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) @@ -532,7 +533,7 @@ program MOM_main dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) @@ -541,7 +542,7 @@ program MOM_main endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + real_to_time_type(t_elapsed_seg) enddo endif @@ -559,7 +560,7 @@ program MOM_main elapsed_time = elapsed_time - floor(elapsed_time) endif if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) + Master_Time = segment_start_time + real_to_time_type(elapsed_time) else Master_Time = Master_Time + Time_step_ocean endif From d9e9457b19cd27de5028b9ff34cb777cac564d27 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Aug 2018 13:32:41 -0400 Subject: [PATCH 17/37] Use real_to_time_type in 63+year segment clock cor Use real_to_time_type in long-time (>63 year segment) ocean-only model clock correction for improved accuracy with fractional timesteps and very long run segments. All answers are bitwise identical in existing test cases. --- config_src/solo_driver/MOM_driver.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 7dd60403c2..f30a740254 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -138,7 +138,7 @@ program MOM_main real :: dt_dyn, dtdia, t_elapsed_seg integer :: n, n_max, nts, n_last_thermo logical :: diabatic_first, single_step_call - type(time_type) :: Time2 + type(time_type) :: Time2, time_chg integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -388,7 +388,7 @@ program MOM_main endif call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & - "If true, advance the state of MOM with a single step \n"//& + "If true, advance the state of MOMtime_chg with a single step \n"//& "including both dynamics and thermodynamics. If false \n"//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mod_name, "DT_THERM", dt_therm, & @@ -550,14 +550,14 @@ program MOM_main ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + dt_forcing if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not lose resolution of order - ! the timetype's resolution, provided that the timestep and tick are - ! larger than 10-5 seconds. If a clock with a finer resolution is used, - ! a smaller value would be required. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time_type(elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then Master_Time = segment_start_time + real_to_time_type(elapsed_time) From 974662e499e89e88955360ab474527a4a11b1844 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Aug 2018 19:19:48 -0400 Subject: [PATCH 18/37] Corrected description of SINGLE_STEPPING_CALL Corrected the documentation in the get_param call for SINGLE_STEPPING_CALL, that was inadvertently messed up two commits ago. All answers are bitwise identical, and inadvertent changes to the MOM_parameter_doc files have been reversed. --- config_src/solo_driver/MOM_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index f30a740254..19901f9a0c 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -388,7 +388,7 @@ program MOM_main endif call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & - "If true, advance the state of MOMtime_chg with a single step \n"//& + "If true, advance the state of MOM with a single step \n"//& "including both dynamics and thermodynamics. If false \n"//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mod_name, "DT_THERM", dt_therm, & From a30575d192ff9f75dd825e3966ef0e414e6faac8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Aug 2018 16:13:14 -0400 Subject: [PATCH 19/37] +Added APPROX_NET_MASS_SRC & moved RESTORE_SALINITY Added code to store an estimate of the net mass source in the mech_forcing type, along with the new run time parameter APPROX_NET_MASS_SRC that controls this behavior. This estimate should be correct for coupled models, but may be off with data overrides or restoring. Because forces%net_mass_src is not yet used in the solution, that answers are invariant to the use of this option. Also moved the get_param calls for RESTORE_SALINITY and RESTORE_TEMPERATURE into surface_forcing_init, and eliminated the corresponding arguments from surface_forcing_init and convert_IOB_to_fluxes, because these parameters were not used in the top-level MOM6 code. Also added a new flag, net_mass_src_set, to the mech_forcing type and dOxygenized the comments in and surrounding the surface_forcing_CS. By default, all answers are bitwise identical, but there is a new run-time parameter, changes to publicly visible interfaces, and the MOM_parameter_doc files change. --- .../coupled_driver/MOM_surface_forcing.F90 | 287 ++++++++++-------- config_src/coupled_driver/ocean_model_MOM.F90 | 22 +- src/core/MOM_forcing_type.F90 | 1 + 3 files changed, 161 insertions(+), 149 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index a4cd1162d7..532ed8081b 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -50,107 +50,106 @@ module MOM_surface_forcing public ice_ocn_bnd_type_chksum public forcing_save_restart - -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive downward. +!> surface_forcing_CS is a structure containing pointers to the forcing fields +!! which may be used to drive MOM. All fluxes are positive downward. type, public :: surface_forcing_CS ; private - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integer values - ! from MOM_domains) to indicate the staggering of - ! the winds that are being provided in calls to - ! update_ocean_model. - logical :: use_temperature ! If true, temp and saln used as state variables + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values + !! from MOM_domains) to indicate the staggering of + !! the winds that are being provided in calls to + !! update_ocean_model. + logical :: use_temperature !< If true, temp and saln used as state variables real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). - real :: Rho0 ! Boussinesq reference density (kg/m^3) - real :: area_surf = -1.0 ! total ocean surface area (m^2) - real :: latent_heat_fusion ! latent heat of fusion (J/kg) - real :: latent_heat_vapor ! latent heat of vaporization (J/kg) - - real :: max_p_surf ! maximum surface pressure that can be - ! exerted by the atmosphere and floating sea-ice, - ! in Pa. This is needed because the FMS coupling - ! structure does not limit the water that can be - ! frozen out of the ocean and the ice-ocean heat - ! fluxes are treated explicitly. - logical :: use_limited_P_SSH ! If true, return the sea surface height with - ! the correction for the atmospheric (and sea-ice) - ! pressure limited by max_p_surf instead of the - ! full atmospheric pressure. The default is true. - - real :: gust_const ! constant unresolved background gustiness for ustar (Pa) - logical :: read_gust_2d ! If true, use a 2-dimensional gustiness supplied - ! from an input file. + real :: Rho0 !< Boussinesq reference density (kg/m^3) + real :: area_surf = -1.0 !< Total ocean surface area (m^2) + real :: latent_heat_fusion !< Latent heat of fusion (J/kg) + real :: latent_heat_vapor !< Latent heat of vaporization (J/kg) + + real :: max_p_surf !< The maximum surface pressure that can be + !! exerted by the atmosphere and floating sea-ice, + !! in Pa. This is needed because the FMS coupling + !! structure does not limit the water that can be + !! frozen out of the ocean and the ice-ocean heat + !! fluxes are treated explicitly. + logical :: use_limited_P_SSH !< If true, return the sea surface height with + !! the correction for the atmospheric (and sea-ice) + !! pressure limited by max_p_surf instead of the + !! full atmospheric pressure. The default is true. + logical :: approx_net_mass_src !< If true, use the net mass sources from the ice-ocean boundary + !! type without any further adjustments to drive the ocean dynamics. + !! The actual net mass source may differ due to corrections. + + real :: gust_const !< Constant unresolved background gustiness for ustar (Pa) + logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. + real, pointer, dimension(:,:) :: & + TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer + !! by drag on the tidal flows, in W m-2. real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & ! turbulent kinetic energy introduced to the - ! bottom boundary layer by drag on the tidal flows, - ! in W m-2. - gust => NULL(), & ! spatially varying unresolved background - ! gustiness that contributes to ustar (Pa). - ! gust is used when read_gust_2d is true. - ustar_tidal => NULL() ! tidal contribution to the bottom friction velocity (m/s) - real :: cd_tides ! drag coefficient that applies to the tides (nondimensional) - real :: utide ! constant tidal velocity to use if read_tideamp - ! is false, in m s-1. - logical :: read_tideamp ! If true, spatially varying tidal amplitude read from a file. - - logical :: rigid_sea_ice ! If true, sea-ice exerts a rigidity that acts - ! to damp surface deflections (especially surface - ! gravity waves). The default is false. - real :: Kv_sea_ice ! viscosity in sea-ice that resists sheared vertical motions (m^2/s) - real :: density_sea_ice ! typical density of sea-ice (kg/m^3). The value is - ! only used to convert the ice pressure into - ! appropriate units for use with Kv_sea_ice. - real :: rigid_sea_ice_mass ! A mass per unit area of sea-ice beyond which - ! sea-ice viscosity becomes effective, in kg m-2, - ! typically of order 1000 kg m-2. - logical :: allow_flux_adjustments ! If true, use data_override to obtain flux adjustments - - real :: Flux_const ! piston velocity for surface restoring (m/s) - logical :: salt_restore_as_sflux ! If true, SSS restore as salt flux instead of water flux - logical :: adjust_net_srestore_to_zero ! adjust srestore to zero (for both salt_flux or vprec) - logical :: adjust_net_srestore_by_scaling ! adjust srestore w/o moving zero contour - logical :: adjust_net_fresh_water_to_zero ! adjust net surface fresh-water (w/ restoring) to zero - logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW - logical :: adjust_net_fresh_water_by_scaling ! adjust net surface fresh-water w/o moving zero contour - logical :: mask_srestore_under_ice ! If true, use an ice mask defined by frazil - ! criteria for salinity restoring. - real :: ice_salt_concentration ! salt concentration for sea ice (kg/kg) - logical :: mask_srestore_marginal_seas ! if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore ! maximum delta salinity used for restoring - real :: max_delta_trestore ! maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() ! mask for SSS restoring by basin - - type(diag_ctrl), pointer :: diag ! structure to regulate diagnostic output timing - character(len=200) :: inputdir ! directory where NetCDF input files are - character(len=200) :: salt_restore_file ! filename for salt restoring data - character(len=30) :: salt_restore_var_name ! name of surface salinity in salt_restore_file - logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface - ! salinity restoring fluxes. The masking file should be - ! in inputdir/salt_restore_mask.nc and the field should - ! be named 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring - character(len=200) :: temp_restore_file ! filename for sst restoring data - character(len=30) :: temp_restore_var_name ! name of surface temperature in temp_restore_file - logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface - ! temperature restoring fluxes. The masking file should be - ! in inputdir/temp_restore_mask.nc and the field should - ! be named 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring - integer :: id_srestore = -1 ! id number for time_interp_external. - integer :: id_trestore = -1 ! id number for time_interp_external. - - ! Diagnostics handles - type(forcing_diags), public :: handles + gust => NULL() !< A spatially varying unresolved background gustiness that + !! contributes to ustar (Pa). gust is used when read_gust_2d is true. + real, pointer, dimension(:,:) :: & + ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity (m/s) + real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) + real :: utide !< Constant tidal velocity to use if read_tideamp is false, in m s-1. + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts to damp surface + !! deflections (especially surface gravity waves). The default is false. + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions (m^2/s) + real :: density_sea_ice !< Typical density of sea-ice (kg/m^3). The value is only used to convert + !! the ice pressure into appropriate units for use with Kv_sea_ice. + real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity + !! becomes effective, in kg m-2, typically of order 1000 kg m-2. + logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + + logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface + !! salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea + !! surface temperature to a specified value. + real :: Flux_const !< Piston velocity for surface restoring (m/s) + logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux + logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) + logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour + logical :: adjust_net_fresh_water_to_zero !< Adjust net surface fresh-water (with restoring) to zero + logical :: use_net_FW_adjustment_sign_bug !< Use the wrong sign when adjusting net FW + logical :: adjust_net_fresh_water_by_scaling !< Adjust net surface fresh-water w/o moving zero contour + logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil criteria + !! for salinity restoring. + real :: ice_salt_concentration !< Salt concentration for sea ice (kg/kg) + logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas + real :: max_delta_srestore !< Maximum delta salinity used for restoring + real :: max_delta_trestore !< Maximum delta sst used for restoring + real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin + + type(diag_ctrl), pointer :: diag => NULL() !< Structure to regulate diagnostic output timing + character(len=200) :: inputdir !< Directory where NetCDF input files are + character(len=200) :: salt_restore_file !< Filename for salt restoring data + character(len=30) :: salt_restore_var_name !< Name of surface salinity in salt_restore_file + logical :: mask_srestore !< If true, apply a 2-dimensional mask to the surface + !! salinity restoring fluxes. The masking file should be + !! in inputdir/salt_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + character(len=200) :: temp_restore_file !< Filename for sst restoring data + character(len=30) :: temp_restore_var_name !< Name of surface temperature in temp_restore_file + logical :: mask_trestore !< If true, apply a 2-dimensional mask to the surface + !! temperature restoring fluxes. The masking file should be + !! in inputdir/temp_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring + integer :: id_srestore = -1 !< An id number for time_interp_external. + integer :: id_trestore = -1 !< An id number for time_interp_external. + + type(forcing_diags), public :: handles !< Diagnostics handles !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + type(user_revise_forcing_CS), pointer :: urf_CS => NULL() !< A control structure for user forcing revisions end type surface_forcing_CS -! ice_ocean_boundary_type is a structure corresponding to forcing, but with -! the elements, units, and conventions that exactly conform to the use for -! MOM-based coupled models. +!> ice_ocean_boundary_type is a structure corresponding to forcing, but with the elements, units, +!! and conventions that exactly conform to the use for MOM6-based coupled models. type, public :: ice_ocean_boundary_type real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress (Pa) real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress (Pa) @@ -179,25 +178,23 @@ module MOM_surface_forcing !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model in (m3/s) - integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT - type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of - !! named fields used for passive tracer fluxes. - integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of - !! wind stresses. This flag may be set by the - !! flux-exchange code, based on what the sea-ice - !! model is providing. Otherwise, the value from - !! the surface_forcing_CS is used. + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields + !! used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of wind stresses. + !! This flag may be set by the flux-exchange code, based on what + !! the sea-ice model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. end type ice_ocean_boundary_type -integer :: id_clock_forcing +integer :: id_clock_forcing !< A CPU time clock contains !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & - sfc_state, restore_salt, restore_temp) +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, sfc_state) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -212,9 +209,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & !! previous call to surface_forcing_init. type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the !! surface state of the ocean. - logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. - logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. - real, dimension(SZI_(G),SZJ_(G)) :: & data_restore, & ! The surface value toward which to restore (g/kg or degC) @@ -234,10 +228,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - logical :: restore_salinity ! local copy of the argument restore_salt, if it - ! is present, or false (no restoring) otherwise. - logical :: restore_sst ! local copy of the argument restore_temp, if it - ! is present, or false (no restoring) otherwise. real :: delta_sss ! temporary storage for sss diff from restoring value real :: delta_sst ! temporary storage for sst diff from restoring value @@ -264,11 +254,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & fluxes%netFWGlobalAdj = 0.0 fluxes%netFWGlobalScl = 0.0 - restore_salinity = .false. - if (present(restore_salt)) restore_salinity = restore_salt - restore_sst = .false. - if (present(restore_temp)) restore_sst = restore_temp - ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then @@ -305,7 +290,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo - if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization @@ -343,7 +328,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & enddo ; enddo ! Salinity restoring logic - if (restore_salinity) then + if (CS%restore_salt) then call time_interp_external(CS%id_srestore,Time,data_restore) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 @@ -396,7 +381,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & endif ! SST restoring logic - if (restore_sst) then + if (CS%restore_temp) then call time_interp_external(CS%id_trestore,Time,data_restore) do j=js,je ; do i=is,ie delta_sst = data_restore(i,j)- sfc_state%SST(i,j) @@ -593,7 +578,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS, dt_forc ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) - ustar_tmp ! A temporary array of ustars. + net_mass_src, & ! A temporary of net mass sources, in kg m-2 s-1. + ustar_tmp ! A temporary array of ustar values, in m s-1. real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) @@ -702,6 +688,36 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS, dt_forc enddo ; enddo endif + ! Find the net mass source in the input forcing without other adjustments. + if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then + net_mass_src(:,:) = 0.0 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + if (associated(IOB%lprec)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%lprec(i-i0,j-j0) + if (associated(IOB%fprec)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%fprec(i-i0,j-j0) + if (associated(IOB%runoff)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%runoff(i-i0,j-j0) + if (associated(IOB%calving)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%calving(i-i0,j-j0) + if (associated(IOB%q_flux)) & + net_mass_src(i,j) = net_mass_src(i,j) - IOB%q_flux(i-i0,j-j0) + endif ; enddo ; enddo + if (wt1 <= 0.0) then + do j=js,je ; do i=is,ie + forces%net_mass_src(i,j) = wt2*net_mass_src(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + forces%net_mass_src(i,j) = wt1*forces%net_mass_src(i,j) + wt2*net_mass_src(i,j) + enddo ; enddo + endif + forces%net_mass_src_set = .true. + else + forces%net_mass_src_set = .false. + endif + ! Obtain optional ice-berg related fluxes from the IOB type: if (associated(IOB%area_berg)) then ; do j=js,je ; do i=is,ie forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) @@ -1084,7 +1100,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart !> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, restore_temp) +subroutine surface_forcing_init(Time, G, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -1092,10 +1108,6 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module - logical, optional, intent(in) :: restore_salt !< If present and true surface salinity - !! restoring will be applied in this model. - logical, optional, intent(in) :: restore_temp !< If present and true surface temperature - !! restoring will be applied in this model. ! Local variables real :: utide ! The RMS tidal velocity, in m s-1. @@ -1154,11 +1166,19 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "the ice-ocean heat fluxes are treated explicitly. No \n"//& "limit is applied if a negative value is used.", units="Pa", & default=-1.0) + call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & + "If true, the coupled driver will add a globally-balanced \n"//& + "fresh-water flux that drives sea-surface salinity \n"//& + "toward specified values.", default=.false.) + call get_param(param_file, mdl, "RESTORE_TEMPERATURE", CS%restore_temp, & + "If true, the coupled driver will add a \n"//& + "heat flux that drives sea-surface temperauture \n"//& + "toward specified values.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & "If true, adjusts the salinity restoring seen to zero\n"//& "whether restoring is via a salt flux or virtual precip.",& - default=restore_salt) + default=CS%restore_salt) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & CS%adjust_net_srestore_by_scaling, & "If true, adjustments to salt restoring to achieve zero net are\n"//& @@ -1188,6 +1208,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "correction for the atmospheric (and sea-ice) pressure \n"//& "limited by max_p_surf instead of the full atmospheric \n"//& "pressure.", default=.true.) + call get_param(param_file, mdl, "APPROX_NET_MASS_SRC", CS%approx_net_mass_src, & + "If true, use the net mass sources from the ice-ocean \n"//& + "boundary type without any further adjustments to drive \n"//& + "the ocean dynamics. The actual net mass source may differ \n"//& + "due to internal corrections.", default=.false.) call get_param(param_file, mdl, "WIND_STAGGER", stagger, & "A case-insensitive character string to indicate the \n"//& @@ -1203,7 +1228,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "coupler. This is used for testing and should be =1.0 for any\n"//& "production runs.", default=1.0) - if (restore_salt) then + if (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes \n"//& "to the relative surface anomalies (akin to a piston \n"//& @@ -1251,7 +1276,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "a mask for SSS restoring.", default=.false.) endif - if (restore_temp) then + if (CS%restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes \n"//& "to the relative surface anomalies (akin to a piston \n"//& @@ -1370,7 +1395,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) endif - if (present(restore_salt)) then ; if (restore_salt) then + if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 @@ -1378,9 +1403,9 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1) endif - endif ; endif + endif - if (present(restore_temp)) then ; if (restore_temp) then + if (CS%restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 @@ -1388,7 +1413,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) endif - endif ; endif + endif ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index e3fd612c70..44d94a77f6 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -149,10 +149,6 @@ module ocean_model_mod logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. - logical :: restore_salinity !< If true, the coupled MOM driver adds a term to - !! restore salinity to a specified value. - logical :: restore_temp !< If true, the coupled MOM driver adds a term to - !! restore sst to a specified value. real :: press_to_z !< A conversion factor between pressure and ocean !! depth in m, usually 1/(rho_0*g), in m Pa-1. real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. @@ -311,14 +307,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & trim(stagger)//" is invalid.") ; endif - call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& - "toward specified values.", default=.false.) call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to \n"//& "calculate accelerations and the mass for conservation \n"//& @@ -343,7 +331,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) do_integrals=.true., gas_fields_ocn=gas_fields_ocn) call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + OS%forcing_CSp) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & @@ -486,8 +474,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (do_thermo) then if (OS%fluxes%fluxes_used) then call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, & - OS%restore_temp) + OS%grid, OS%forcing_CSp, OS%sfc_state) ! Add ice shelf fluxes if (OS%use_ice_shelf) & @@ -508,8 +495,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! into a temporary type and then accumulate them in about 20 lines. OS%flux_tmp%C_p = OS%fluxes%C_p call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, & - OS%restore_temp) + OS%grid, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) @@ -523,7 +509,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #endif endif endif - if (associated(OS%forces%net_mass_src)) & + if (associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) if (OS%use_waves) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 1df0fe1473..ba170c63f4 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -212,6 +212,7 @@ module MOM_forcing_type rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points (m3/s) real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged, in s. + logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the !! surface pressure explicitly reset to zero at the driver level From 6c4681130b9bec8abffe9372de09649627e15ed9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Aug 2018 18:51:27 -0400 Subject: [PATCH 20/37] +Removed forcing type arg from mech_forcing_diags Moved 4 diagnostics from mech_forcing_diags to forcing_diagnostics and removed the now unused (thermodynamic) forcing type argument fluxes from mech_forcing_diags, so that the location of the diagnostics better reflects their use in stepping MOM6. All calls to mech_forcing_diags in the drivers were changed accordingly. Also, a new element, nstep_thermo, was added to the ocean_state_type to allow dynamic and thermodynamic calls to update_ocean_model to be counted separately, and some additional calls now only occur if the dynamics or thermodynamics are being stepped. All answers are bitwise identical, but one publicly visible interface has changed. --- config_src/coupled_driver/ocean_model_MOM.F90 | 40 +++++++++++------- config_src/mct_driver/ocn_comp_mct.F90 | 3 +- config_src/solo_driver/MOM_driver.F90 | 3 +- src/core/MOM_forcing_type.F90 | 42 ++++++++++++------- 4 files changed, 52 insertions(+), 36 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 44d94a77f6..37df04d8e7 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -20,7 +20,7 @@ module ocean_model_mod use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : TO_ALL, Omit_Corners -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type @@ -143,7 +143,8 @@ module ocean_model_mod !! restart file is saved at the end of a run segment !! unless Restart_control is negative. - integer :: nstep = 0 !< The number of calls to update_ocean. + integer :: nstep = 0 !< The number of calls to update_ocean that update the dynamics. + integer :: nstep_thermo = 0 !< The number of calls to update_ocean that update the thermodynamics. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. logical :: use_waves !< If true use wave coupling. @@ -375,8 +376,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) - if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + call MOM_mesg('==== Completed MOM6 Coupled Initialization ====', 2) call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -485,7 +485,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #ifdef _USE_GENERIC_TRACER call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) !here weight=1, so just saving the current fluxes + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes #endif ! Indicate that there are new unused fluxes. OS%fluxes%fluxes_used = .false. @@ -505,25 +505,31 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) #ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average + ! Incorporate the current tracer fluxes into the running averages + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) #endif endif endif - if (associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & + + ! The net mass forcing is not currently used in the MOM6 dynamics solvers, so this is may be unnecessary. + if (do_dyn .and. associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) - if (OS%use_waves) then + if (OS%use_waves .and. do_thermo) then + ! For now, the waves are only updated on the thermodynamics steps, because that is where + ! the wave intensities are actually used to drive mixing. At some point, the wave updates + ! might also need to become a part of the ocean dynamics, according to B. Reichl. call Update_Surface_Waves(OS%grid, OS%GV, OS%time, ocean_coupling_time_step, OS%waves) endif - if (OS%nstep==0) then + if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time - if (OS%offline_tracer_mode) then + if (OS%offline_tracer_mode .and. do_thermo) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. @@ -593,14 +599,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif OS%Time = Master_time + Ocean_coupling_time_step - OS%nstep = OS%nstep + 1 + if (do_dyn) OS%nstep = OS%nstep + 1 + if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 - call enable_averaging(dt_coupling, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, OS%fluxes, dt_coupling, OS%grid, & - OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + if (do_dyn) then + call enable_averaging(dt_coupling, OS%Time, OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + endif - if (OS%fluxes%fluxes_used) then + if (OS%fluxes%fluxes_used .and. do_thermo) then call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%diag, OS%forcing_CSp%handles) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index d294c29656..d2de157a49 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -1790,8 +1790,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & OS%nstep = OS%nstep + 1 call enable_averaging(time_step, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, OS%fluxes, time_step, OS%grid, & - OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, time_step, OS%grid, OS%diag, OS%forcing_CSp%handles) call disable_averaging(OS%diag) if (OS%fluxes%fluxes_used) then diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 19901f9a0c..da0f77d935 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -571,8 +571,7 @@ program MOM_main endif ; endif call enable_averaging(dt_forcing, Time, diag) - call mech_forcing_diags(forces, fluxes, dt_forcing, grid, diag, & - surface_forcing_CSp%handles) + call mech_forcing_diags(forces, dt_forcing, grid, diag, surface_forcing_CSp%handles) call disable_averaging(diag) if (.not. offline_tracer_mode) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ba170c63f4..857979f61d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -298,7 +298,7 @@ module MOM_forcing_type integer :: id_netFWGlobalAdj = -1 integer :: id_netFWGlobalScl = -1 - ! momentum flux amd forcing diagnostic handles + ! momentum flux and forcing diagnostic handles integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 @@ -1038,6 +1038,11 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, haloshift) haloshift=hshift, symmetric=.true.) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) + if (associated(forces%ustar)) & + call hchksum(forces%ustar, mesg//" forces%ustar",G%HI,haloshift=hshift) + if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & + call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & + forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true.) end subroutine MOM_mech_forcing_chksum @@ -2054,9 +2059,8 @@ end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine mech_forcing_diags(forces, fluxes, dt, G, diag, handles) +subroutine mech_forcing_diags(forces, dt, G, diag, handles) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields real, intent(in) :: dt !< time step type(ocean_grid_type), intent(in) :: G !< grid type type(diag_ctrl), intent(in) :: diag !< diagnostic type @@ -2071,20 +2075,15 @@ subroutine mech_forcing_diags(forces, fluxes, dt, G, diag, handles) if ((handles%id_taux > 0) .and. associated(forces%taux)) & call post_data(handles%id_taux, forces%taux, diag) + if ((handles%id_tauy > 0) .and. associated(forces%tauy)) & call post_data(handles%id_tauy, forces%tauy, diag) - if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & - call post_data(handles%id_ustar, fluxes%ustar, diag) - if (handles%id_ustar_berg > 0) & - call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) - if (handles%id_area_berg > 0) & - call post_data(handles%id_area_berg, fluxes%area_berg, diag) - if (handles%id_mass_berg > 0) & - call post_data(handles%id_mass_berg, fluxes%mass_berg, diag) - if (handles%id_frac_ice_cover > 0) & - call post_data(handles%id_frac_ice_cover, fluxes%frac_shelf_h, diag) - if (handles%id_ustar_ice_cover > 0) & - call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) + + if ((handles%id_mass_berg > 0) .and. associated(forces%mass_berg)) & + call post_data(handles%id_mass_berg, forces%mass_berg, diag) + + if ((handles%id_area_berg > 0) .and. associated(forces%area_berg)) & + call post_data(handles%id_area_berg, forces%area_berg, diag) endif @@ -2575,8 +2574,19 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & call post_data(handles%id_buoy, fluxes%buoy, diag) + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & + call post_data(handles%id_ustar, fluxes%ustar, diag) - endif + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & + call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) + + if ((handles%id_frac_ice_cover > 0) .and. associated(fluxes%frac_shelf_h)) & + call post_data(handles%id_frac_ice_cover, fluxes%frac_shelf_h, diag) + + if ((handles%id_ustar_ice_cover > 0) .and. associated(fluxes%ustar_shelf)) & + call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) + + endif ! query_averaging_enabled call cpu_clock_end(handles%id_clock_forcing) end subroutine forcing_diagnostics From 0cb2d87ab0a44c030b839ac72f75733aebf29454 Mon Sep 17 00:00:00 2001 From: "Jessica.Liptak" Date: Thu, 9 Aug 2018 16:09:44 -0400 Subject: [PATCH 21/37] removed underscore from allocated statement in MOM_generic_tracer_column_physics routine --- src/tracer/MOM_generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index d06ffe0e2c..48b8e4512c 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -498,7 +498,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (_allocated(g_tracer%trunoff)) then + if (allocated(g_tracer%trunoff)) then call g_tracer_get_alias(g_tracer,g_tracer_name) call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) From 0bd868837b866211e3eaf899079fe5aceb858849 Mon Sep 17 00:00:00 2001 From: Raymond Menzel Date: Thu, 9 Aug 2018 17:18:33 -0400 Subject: [PATCH 22/37] Allocate surface tracers on the compute domain instead of the data domain. --- src/core/MOM_variables.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 4165fb0e11..4a2dbbea54 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -338,7 +338,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & if (present(gas_fields_ocn)) & call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/isd,is,ie,ied/), (/jsd,js,je,jed/), as_needed=.true.) + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) sfc_state%arrays_allocated = .true. From c4529f3de50ced17375d1595b68f608742cb80c0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Aug 2018 19:24:16 -0400 Subject: [PATCH 23/37] +Added optional arguments to updaet_ocean_model Added optional start_cycle, end_cycle, and cycle_length arguments to update_ocean_model, for use with dynamics- or thermodynamics-only steps. Also added a separate clock to the ocean_state_type for the ocean dynamics, to keep track of time when the dynamics and thermodynamics are updated separately. Also cleaned up comments describing local variables and eliminated a redundant variable. All answers are bitwise identical, even when there are separate calls to step the ocean dynamics and thermodynamics. --- config_src/coupled_driver/ocean_model_MOM.F90 | 131 ++++++++++-------- 1 file changed, 74 insertions(+), 57 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 37df04d8e7..742688506f 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -136,6 +136,8 @@ module ocean_model_mod ! This type is private, and can therefore vary between different ocean models. logical :: is_ocean_PE = .false. !< True if this is an ocean PE. type(time_type) :: Time !< The ocean model's time and master clock. + type(time_type) :: Time_dyn !< The ocean model's time for the dynamics. Time and Time_dyn + !! should be the same after a full time step. integer :: Restart_control !< An integer that is bit-tested to determine whether !! incremental restart files are saved and whether they !! have a time stamped name. +1 (bit 0) for generic @@ -254,7 +256,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return - OS%Time = Time_in + OS%Time = Time_in ; OS%Time_dyn = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true.) @@ -386,23 +388,22 @@ end subroutine ocean_model_init !! time time_start_update) for a time interval of Ocean_coupling_time_step, !! returning the publicly visible ocean surface properties in Ocean_sfc and !! storing the new ocean properties in Ocean_state. -subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & - time_start_update, Ocean_coupling_time_step, & - update_dyn, update_thermo, Ocn_fluxes_used) +subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_update, & + Ocean_coupling_time_step, update_dyn, update_thermo, & + Ocn_fluxes_used, start_cycle, end_cycle, cycle_length) type(ice_ocean_boundary_type), & - intent(in) :: Ice_ocean_boundary !< A structure containing the - !! various forcing fields coming from the ice. + intent(in) :: Ice_ocean_boundary !< A structure containing the various + !! forcing fields coming from the ice and atmosphere. type(ocean_state_type), & - pointer :: OS !< A pointer to a private structure containing - !! the internal ocean state. + pointer :: OS !< A pointer to a private structure containing the + !! internal ocean state. type(ocean_public_type), & - intent(inout) :: Ocean_sfc !< A structure containing all the - !! publicly visible ocean surface fields after - !! a coupling time step. The data in this type is - !! intent out. + intent(inout) :: Ocean_sfc !< A structure containing all the publicly visible + !! ocean surface fields after a coupling time step. + !! The data in this type is intent out. type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. - type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over - !! which to advance the ocean. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over which to + !! advance the ocean. logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates !! due to the ocean dynamics. logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates @@ -410,37 +411,38 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & logical, optional, intent(in) :: Ocn_fluxes_used !< If present, this indicates whether the !! cumulative thermodynamic fluxes from the ocean, !! like frazil, have been used and should be reset. + logical, optional, intent(in) :: start_cycle !< This indicates whether this call is to be + !! treated as the first call to step_MOM in a + !! time-stepping cycle; missing is like true. + logical, optional, intent(in) :: end_cycle !< This indicates whether this call is to be + !! treated as the last call to step_MOM in a + !! time-stepping cycle; missing is like true. + real, optional, intent(in) :: cycle_length !< The duration of a coupled time stepping cycle, in s. + ! Local variables - type(time_type) :: Master_time ! This allows step_MOM to temporarily change - ! the time that is seen by internal modules. - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - integer :: index_bnds(4) ! The computational domain index bounds in the - ! ice-ocean boundary type. - real :: weight ! Flux accumulation weight of the current fluxes. - real :: dt_coupling ! The coupling time step in seconds. - integer :: nts ! The number of baroclinic dynamics time steps - ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. - integer :: n, n_max, n_last_thermo - type(time_type) :: Time2 ! A temporary time. - logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans - ! multiple dynamic timesteps. - logical :: do_dyn ! If true, step the ocean dynamics and transport. - logical :: do_thermo ! If true, step the ocean thermodynamics. - logical :: step_thermo ! If true, take a thermodynamic step. + type(time_type) :: Time_seg_start ! Stores the ocean model time at the start of this call to allow + ! step_MOM to temporarily change the time as seen by internal modules. + type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. + integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. + real :: weight ! Flux accumulation weight of the current fluxes. + real :: dt_coupling ! The coupling time step in seconds. + real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) + real :: dt_dyn ! The dynamics time step in sec. + real :: dtdia ! The diabatic time step in sec. + real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + integer :: n ! The internal iteration counter. + integer :: nts ! The number of baroclinic dynamics time steps in a thermodynamic step. + integer :: n_max ! The number of calls to step_MOM dynamics in this call to update_ocean_model. + integer :: n_last_thermo ! The iteration number the last time thermodynamics were updated. + logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans multiple dynamic timesteps. + logical :: do_dyn ! If true, step the ocean dynamics and transport. + logical :: do_thermo ! If true, step the ocean thermodynamics. + logical :: step_thermo ! If true, take a thermodynamic step. integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") dt_coupling = time_type_to_real(Ocean_coupling_time_step) - if (time_start_update /= OS%Time) then - call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& - "agree with time_start_update argument.") - endif if (.not.associated(OS)) then call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & "ocean_state_type structure. ocean_model_init must be "// & @@ -451,6 +453,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo + if (do_thermo .and. (time_start_update /= OS%Time)) & + call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& + "agree with time_start_update argument.") + if (do_dyn .and. (time_start_update /= OS%Time_dyn)) & + call MOM_error(WARNING, "update_ocean_model: internal dynamics clock does not "//& + "agree with time_start_update argument.") + + if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL, & + "update_ocean_model called without updating either dynamics or thermodynamics.") + if (do_dyn .and. do_thermo .and. (OS%Time /= OS%Time_dyn)) call MOM_error(FATAL, & + "update_ocean_model called to update both dynamics and thermodynamics with inconsistent clocks.") + ! This is benign but not necessary if ocean_model_init_sfc was called or if ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec @@ -462,7 +476,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & index_bnds(3), index_bnds(4)) if (do_dyn) then - call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, OS%grid, & + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time_dyn, OS%grid, & OS%forcing_CSp, dt_forcing=dt_coupling, reset_avg=OS%fluxes%fluxes_used) if (OS%use_ice_shelf) & call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) @@ -486,6 +500,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #ifdef _USE_GENERIC_TRACER call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes + call disable_averaging(OS%diag) #endif ! Indicate that there are new unused fluxes. OS%fluxes%fluxes_used = .false. @@ -522,22 +537,21 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call Update_Surface_Waves(OS%grid, OS%GV, OS%time, ocean_coupling_time_step, OS%waves) endif - if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then + if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif - call disable_averaging(OS%diag) - Master_time = OS%Time ; Time1 = OS%Time + Time_seg_start = OS%Time ; if (do_dyn) Time_seg_start = OS%Time_dyn + Time1 = Time_seg_start if (OS%offline_tracer_mode .and. do_thermo) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & - Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & + Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & + start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) - !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) - elseif (OS%single_step_call) then call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else @@ -553,7 +567,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & n_last_thermo = 0 endif - Time2 = Time1 ; t_elapsed_seg = 0.0 + Time1 = Time_seg_start ; t_elapsed_seg = 0.0 do n=1,n_max if (OS%diabatic_first) then if (thermo_does_span_coupling) call MOM_error(FATAL, & @@ -561,16 +575,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) @@ -585,25 +599,27 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (step_thermo) then - ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + ! Back up Time1 to the start of the thermodynamic segment. + Time1 = Time1 - real_to_time_type(dtdia - dt_dyn) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + real_to_time_type(t_elapsed_seg) + Time1 = Time_seg_start + real_to_time_type(t_elapsed_seg) enddo endif - OS%Time = Master_time + Ocean_coupling_time_step + if (do_dyn) OS%Time_dyn = Time_seg_start + Ocean_coupling_time_step if (do_dyn) OS%nstep = OS%nstep + 1 + OS%Time = Time_seg_start ! Reset the clock to compensate for shared pointers. + if (do_thermo) OS%Time = OS%Time + Ocean_coupling_time_step if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 if (do_dyn) then - call enable_averaging(dt_coupling, OS%Time, OS%diag) + call enable_averaging(dt_coupling, OS%Time_dyn, OS%diag) call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) call disable_averaging(OS%diag) endif @@ -619,7 +635,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - call coupler_type_send_data(Ocean_sfc%fields, OS%Time) + Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn + call coupler_type_send_data(Ocean_sfc%fields, Time1) call callTree_leave("update_ocean_model()") end subroutine update_ocean_model From 40466156dec6f9ed43185a2d11d8cb9bf3398cbb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Aug 2018 14:31:56 -0400 Subject: [PATCH 24/37] Removed trailing white space --- config_src/coupled_driver/MOM_surface_forcing.F90 | 2 +- src/core/MOM_forcing_type.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 532ed8081b..bbaac1df07 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -642,7 +642,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS, dt_forc if (present(reset_avg)) then ; if (reset_avg) forces%dt_force_accum = 0.0 ; endif wt1 = 0.0 ; wt2 = 1.0 if (present(dt_forcing)) then - if ((forces%dt_force_accum > 0.0) .and. (dt_forcing > 0.0)) then + if ((forces%dt_force_accum > 0.0) .and. (dt_forcing > 0.0)) then wt1 = forces%dt_force_accum / (forces%dt_force_accum + dt_forcing) wt2 = 1.0 - wt1 endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 857979f61d..9ac616dac0 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1998,7 +1998,7 @@ end subroutine set_derived_forcing_fields subroutine set_net_mass_forcing(fluxes, forces, G) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(ocean_grid_type), intent(in) :: G !< The ocean grid type + type(ocean_grid_type), intent(in) :: G !< The ocean grid type if (associated(forces%net_mass_src)) & call get_net_mass_forcing(fluxes, G, forces%net_mass_src) From 3bf78bd416a64497bc7b283c8a7efa7b6d4e267e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Aug 2018 17:34:08 -0400 Subject: [PATCH 25/37] Avoid NaNs on land in ALE diagnostics Some of the temporary arrays used to calculate ALE tendencies were not being initialized, so there could be NaNs or other silly values reported over land. The needed array initialization calls were removed with NOAA-GFDL/MOM6@11c2a91, but have now been restored, and the diagnostics are only calculated and offered if remap_all_state_vars are given a diagnostic time-step (without which the diagnostics make no sense). This commit addresses issue number github.com/NOAA-GFDL/MOM6/issues/829. All answers are bitwise identical. --- src/ALE/MOM_ALE.F90 | 41 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a71dfb557c..7e2885fd6f 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -760,14 +760,12 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, nz = GV%ke ppt2mks = 0.001 - if (associated(Reg)) then - ntr = Reg%ntr - else - ntr = 0 - endif + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr if (present(dt)) then Idt = 1.0/dt + work_conc(:,:,:) = 0.0 + work_cont(:,:,:) = 0.0 endif ! Remap tracer @@ -801,22 +799,23 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, endif ; enddo ; enddo ! tendency diagnostics. - if (Tr%id_remap_conc > 0) then - call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) - endif - if (Tr%id_remap_cont > 0) then - call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) - endif - if (Tr%id_remap_cont_2d > 0) then - do j = G%jsc,G%jec ; do i = G%isc,G%iec - work_2d(i,j) = 0.0 - do k = 1,GV%ke - work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) - enddo - enddo ; enddo - call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + if (present(dt)) then + if (Tr%id_remap_conc > 0) then + call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) + endif + if (Tr%id_remap_cont > 0) then + call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) + endif + if (Tr%id_remap_cont_2d > 0) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_2d(i,j) = 0.0 + do k = 1,GV%ke + work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) + enddo + enddo ; enddo + call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + endif endif - enddo ! m=1,ntr endif ! endif for ntr > 0 @@ -866,7 +865,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, endif if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) - if (CS_ALE%id_vert_remap_h_tendency > 0) then + if ((CS_ALE%id_vert_remap_h_tendency > 0) .and. present(dt)) then do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo From ac757ef71f3036a147b8008381491cfe7dd8508d Mon Sep 17 00:00:00 2001 From: "Jessica.Liptak" Date: Tue, 14 Aug 2018 10:12:46 -0400 Subject: [PATCH 26/37] Capitalized _allocated in MOM_generic tracer to fix bug with intel16 -O0 (debug). --- src/tracer/MOM_generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 48b8e4512c..42db298632 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -498,7 +498,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (allocated(g_tracer%trunoff)) then + if (_ALLOCATED(g_tracer%trunoff)) then call g_tracer_get_alias(g_tracer,g_tracer_name) call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) From e3dc939f93b7dd817deaf8e1a0e9252ca8c97204 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Aug 2018 11:31:05 -0400 Subject: [PATCH 27/37] (*)Increase precision of time handling Replaced the use of set_time and get_time with real_to_time_type and time_type_to_real to increase the precision of handling time by allowing the sub-second ticks to be used effectively, and thereby permitting the use of fractional second timesteps within MOM6. This modification could change answers in cases where times are not an integer number of seconds. However, all existing test cases only use times that are an integer number of seconds, so the answers are bitwise identical in the test cases. --- src/core/MOM.F90 | 35 +++++++++---------- src/core/MOM_barotropic.F90 | 6 ++-- src/core/MOM_dynamics_split_RK2.F90 | 2 +- src/core/MOM_dynamics_unsplit.F90 | 4 +-- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- src/framework/MOM_file_parser.F90 | 10 +++--- src/framework/MOM_horizontal_regridding.F90 | 2 +- src/framework/MOM_restart.F90 | 17 ++++----- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 10 +++--- .../MOM_state_initialization.F90 | 2 +- .../MOM_tracer_initialization_from_Z.F90 | 1 - src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- .../lateral/MOM_internal_tides.F90 | 10 ++---- .../vertical/MOM_diabatic_driver.F90 | 7 ++-- .../vertical/MOM_opacity.F90 | 3 -- src/tracer/DOME_tracer.F90 | 2 +- src/tracer/ISOMIP_tracer.F90 | 2 +- src/tracer/MOM_OCMIP2_CFC.F90 | 2 +- src/tracer/MOM_generic_tracer.F90 | 2 +- src/tracer/advection_test_tracer.F90 | 2 +- src/tracer/boundary_impulse_tracer.F90 | 2 +- src/tracer/dye_example.F90 | 2 +- src/tracer/dyed_obc_tracer.F90 | 2 +- src/tracer/ideal_age_example.F90 | 6 ++-- src/tracer/oil_tracer.F90 | 8 ++--- src/tracer/pseudo_salt_tracer.F90 | 2 +- src/tracer/tracer_example.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 2 +- src/user/Kelvin_initialization.F90 | 2 +- src/user/MOM_controlled_forcing.F90 | 6 ++-- src/user/MOM_wave_interface.F90 | 4 +-- src/user/SCM_CVmix_tests.F90 | 7 ++-- src/user/SCM_idealized_hurricane.F90 | 3 +- src/user/dumbbell_surface_forcing.F90 | 1 + src/user/dyed_channel_initialization.F90 | 2 +- src/user/shelfwave_initialization.F90 | 2 +- src/user/supercritical_initialization.F90 | 2 +- src/user/tidal_bay_initialization.F90 | 2 +- src/user/user_revise_forcing.F90 | 2 +- 40 files changed, 80 insertions(+), 104 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c554e4f92e..bf47d7b08c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -39,7 +39,7 @@ module MOM use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_time_manager, only : operator(>=), increment_date use MOM_unit_tests, only : unit_tests @@ -556,7 +556,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo if (associated(CS%VarMix)) then - call enable_averaging(cycle_time, Time_start+set_time(int(cycle_time)), & + call enable_averaging(cycle_time, Time_start + real_to_time_type(cycle_time), & CS%diag) call calc_resoln_function(h, CS%tv, G, GV, CS%VarMix) call disable_averaging(CS%diag) @@ -582,7 +582,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom - call enable_averaging(time_interval, Time_start + set_time(int(floor(time_interval+0.5))), CS%diag) + call enable_averaging(time_interval, Time_start + real_to_time_type(time_interval), CS%diag) call Update_Stokes_Drift(G, GV, Waves, h, forces%ustar) call disable_averaging(CS%diag) endif @@ -604,9 +604,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do n=1,n_max rel_time = rel_time + dt ! The relative time at the end of the step. ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) ! Set the local time to the end of the time step. - Time_local = Time_start + set_time(int(floor(rel_time+0.5))) + Time_local = Time_start + real_to_time_type(rel_time) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -633,10 +633,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (dtdia > dt) then ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they begin at the same time. - CS%Time = CS%Time + set_time(int(floor(0.5*(dtdia-dt) + 0.5))) + CS%Time = CS%Time + real_to_time_type(0.5*(dtdia-dt)) ! The end-time of the diagnostic interval needs to be set ahead if there ! are multiple dynamic time steps worth of thermodynamics applied here. - end_time_thermo = Time_local + set_time(int(floor(dtdia-dt+0.5))) + end_time_thermo = Time_local + real_to_time_type(dtdia-dt) endif ! Apply diabatic forcing, do mixing, and regrid. @@ -649,7 +649,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then @@ -731,7 +731,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - if (dtdia > dt) CS%Time = CS%Time - set_time(int(floor(0.5*(dtdia-dt) + 0.5))) + if (dtdia > dt) CS%Time = CS%Time - real_to_time_type(0.5*(dtdia-dt)) ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & @@ -740,7 +740,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%t_dyn_rel_thermo = 0.0 if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) endif if (do_dyn) then @@ -774,7 +774,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%t_dyn_rel_diag = 0.0 call cpu_clock_begin(id_clock_Z_diag) - if (Time_local + set_time(int(0.5*dt_therm)) > CS%Z_diag_time) then + if (Time_local + real_to_time_type(0.5*dt_therm) > CS%Z_diag_time) then call enable_averaging(real(time_type_to_real(CS%Z_diag_interval)), & CS%Z_diag_time, CS%diag) !### This is the one place where fluxes might used if do_thermo=.false. Is this correct? @@ -852,7 +852,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & G, GV, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=set_time(int(floor(time_interval+0.5))) ) + dt_forcing=real_to_time_type(time_interval) ) call cpu_clock_end(id_clock_other) @@ -912,7 +912,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo, Time_local+set_time(int(floor(dt_thermo-dt+0.5))), CS%diag) + call enable_averaging(dt_thermo, Time_local+real_to_time_type(dt_thermo-dt), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) @@ -931,7 +931,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then call enable_averaging(bbl_time_int, & - Time_local + set_time(int(bbl_time_int-dt+0.5)), CS%diag) + Time_local + real_to_time_type(bbl_time_int-dt), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, & @@ -2286,7 +2286,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = set_time(int(floor(CS%dtbt_reset_period))) + CS%dtbt_reset_interval = real_to_time_type(CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & ((Time - Time_init) / CS%dtbt_reset_interval) @@ -2325,11 +2325,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & param_file, diag, CS%diagnostics_CSp, CS%tv) call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) - CS%Z_diag_interval = set_time(int((CS%dt_therm) * & - max(1,floor(0.01 + Z_diag_int/(CS%dt_therm))))) + CS%Z_diag_interval = real_to_time_type(CS%dt_therm * max(1,floor(0.01 + Z_diag_int/CS%dt_therm))) call MOM_diag_to_Z_init(Time, G, GV, param_file, diag, CS%diag_to_Z_CSp) CS%Z_diag_time = Start_time + CS%Z_diag_interval * (1 + & - ((Time + set_time(int(CS%dt_therm))) - Start_time) / CS%Z_diag_interval) + ((Time + real_to_time_type(CS%dt_therm)) - Start_time) / CS%Z_diag_interval) if (associated(CS%sponge_CSp)) & call init_sponge_diags(Time, G, diag, CS%sponge_CSp) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 940c99b8be..c423b2d0c1 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -22,7 +22,7 @@ module MOM_barotropic use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS -use MOM_time_manager, only : time_type, set_time, operator(+), operator(-) +use MOM_time_manager, only : time_type, real_to_time_type, operator(+), operator(-) use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -723,7 +723,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) & - time_bt_start = time_end_in - set_time(int(floor(dt+0.5))) + time_bt_start = time_end_in - real_to_time_type(dt) endif !--- begin setup for group halo update @@ -2008,7 +2008,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & enddo ; enddo if (do_hifreq_output) then - time_step_end = time_bt_start + set_time(int(floor(n*dtbt+0.5))) + time_step_end = time_bt_start + real_to_time_type(n*dtbt) call enable_averaging(dtbt, time_step_end, CS%diag) if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index d02285148a..0f4bd88111 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -30,7 +30,7 @@ module MOM_dynamics_split_RK2 use MOM_io, only : MOM_io_init, vardesc, var_desc use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 47d3510c5a..506dd3624b 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -72,7 +72,7 @@ module MOM_dynamics_unsplit use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time_type, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS @@ -267,7 +267,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averaging(0.5*dt,Time_local-set_time(int(0.5*dt)), CS%diag) + call enable_averaging(0.5*dt,Time_local-real_to_time_type(0.5*dt), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index a1615ad413..0f6d61905e 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -70,7 +70,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index ae876b16dd..70f3b9a941 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -6,8 +6,8 @@ module MOM_file_parser use MOM_coms, only : root_PE, broadcast use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_error_handler, only : is_root_pe, stdlog, stdout -use MOM_time_manager, only : set_time, get_time, time_type, get_ticks_per_second -use MOM_time_manager, only : set_date, get_date +use MOM_time_manager, only : get_time, time_type, get_ticks_per_second +use MOM_time_manager, only : set_date, get_date, real_to_time_type use MOM_document, only : doc_param, doc_module, doc_init, doc_end, doc_type use MOM_document, only : doc_openBlock, doc_closeBlock use MOM_string_functions, only : left_int, left_ints, slasher @@ -821,7 +821,7 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f character(len=240) :: err_msg logical :: found, defined real :: real_time, time_unit - integer :: days, secs, vals(7) + integer :: vals(7) if (present(date_format)) date_format = .false. @@ -854,9 +854,7 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f else time_unit = 1.0 ; if (present(timeunit)) time_unit = timeunit read( value_string(1), *) real_time - days = int(real_time*(time_unit/86400.0)) - secs = int(floor((real_time*(time_unit/86400.0)-days)*86400.0 + 0.5)) - value = set_time(secs, days) + value = real_to_time_type(real_time*time_unit) endif else if (present(fail_if_missing)) then ; if (fail_if_missing) then diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 19b73ee07f..c7befad3b3 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -19,7 +19,7 @@ module MOM_horizontal_regridding use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, write_field use MOM_string_functions, only : uppercase -use MOM_time_manager, only : time_type, set_time, get_external_field_size +use MOM_time_manager, only : time_type, get_external_field_size use MOM_time_manager, only : init_external_field, time_interp_external use MOM_time_manager, only : get_external_field_axes, get_external_field_missing use MOM_variables, only : thermo_var_ptrs diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index bf40da4897..436d514125 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -14,8 +14,8 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_time_manager, only : time_type, get_time, get_date, set_date, set_time -use MOM_time_manager, only : days_in_month +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time_type +use MOM_time_manager, only : days_in_month, get_date, set_date use MOM_verticalGrid, only : verticalGrid_type use mpp_mod, only: mpp_chksum use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts @@ -801,15 +801,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) ! With parallel read & write, it is possible to disable the following... -! jgj: this was set to 4294967292, changed to 4294967295 (see mpp_parameter.F90) - if (CS%large_file_support) max_file_size = 4294967295_8 + ! The maximum file size is 4294967292, according to the NetCDF documentation. + if (CS%large_file_support) max_file_size = 4294967292_8 num_files = 0 next_var = 0 nz = 1 ; if (present(GV)) nz = GV%ke - call get_time(time,seconds,days) - restart_time = real(days) + real(seconds)/86400.0 + restart_time = time_type_to_real(time) restartname = trim(CS%restartfile) if (present(filename)) restartname = trim(filename) @@ -982,7 +981,7 @@ subroutine restore_state(filename, directory, day, G, CS) character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. - integer :: i, n, m, start_of_day, num_days, missing_fields + integer :: i, n, m, missing_fields integer :: isL, ieL, jsL, jeL, is0, js0 integer :: sizes(7) integer :: ndim, nvar, natt, ntime, pos @@ -1028,9 +1027,7 @@ subroutine restore_state(filename, directory, day, G, CS) t1 = time_vals(1) deallocate(time_vals) - start_of_day = INT((t1 - INT(t1)) *86400) ! Number of seconds. - num_days = INT(t1) - day = set_time(start_of_day, num_days) + day = real_to_time_type(t1) exit enddo diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index e1a61f355c..7e3c4ac606 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -25,7 +25,7 @@ module MOM_ice_shelf use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_variables, only : surface use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e504db90c7..9d25d8c8a3 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -17,7 +17,7 @@ module MOM_ice_shelf_dynamics use MOM_io, only : file_exists, slasher, MOM_read_data use MOM_restart, only : register_restart_field, query_initialized use MOM_restart, only : MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, set_time !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs @@ -523,13 +523,13 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, Time) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(time_type), intent(in) :: Time !< The current model time - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi, rhow, OD + type(time_type) :: dummy_time rhoi = CS%density_ice rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) + dummy_time = set_time(0,0) isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed do j=jsd,jed diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0f9c17022d..57820accc0 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -34,7 +34,7 @@ module MOM_state_initialization use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase -use MOM_time_manager, only : time_type, set_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 67cf7bbd24..07be1ee340 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -16,7 +16,6 @@ module MOM_tracer_initialization_from_Z use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_string_functions, only : uppercase -use MOM_time_manager, only : time_type, set_time use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 17cc300bd2..f9dae9b246 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -19,7 +19,7 @@ module MOM_oda_driver_mod use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist use time_manager_mod, only : time_type, decrement_time, increment_time -use time_manager_mod, only : get_date, get_time, operator(>=),operator(/=),operator(==),operator(<) +use time_manager_mod, only : get_date, operator(>=),operator(/=),operator(==),operator(<) use constants_mod, only : radius, epsln ! ODA Modules use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 3205f81b02..822c11470e 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -18,9 +18,7 @@ module MOM_internal_tides use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean -use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) -use MOM_time_manager, only : get_time, get_date, set_time, set_date -use MOM_time_manager, only : time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS @@ -592,13 +590,8 @@ subroutine sum_En(G, CS, En, label) integer :: m,fr,a real :: En_sum, tmpForSumming, En_sum_diff, En_sum_pdiff character(len=160) :: mesg ! The text of an error message - integer :: seconds - real :: Isecs_per_day = 1.0 / 86400.0 real :: days - call get_time(CS%Time, seconds) - days = real(seconds) * Isecs_per_day - En_sum = 0.0 tmpForSumming = 0.0 do a=1,CS%nAngle @@ -614,6 +607,7 @@ subroutine sum_En(G, CS, En, label) CS%En_sum = En_sum !! Print to screen !if (is_root_pe()) then + ! days = time_type_to_real(CS%Time) / 86400.0 ! write(mesg,*) trim(label)//': days =', days, ', En_sum=', En_sum, & ! ', En_sum_diff=', En_sum_diff, ', Percent change=', En_sum_pdiff, '%' ! call MOM_mesg(mesg) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 188ba9c8f3..846e27de8b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -61,8 +61,7 @@ module MOM_diabatic_driver use MOM_shortwave_abs, only : absorbRemainingSW, optics_type use MOM_sponge, only : apply_sponge, sponge_CS use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS -use MOM_time_manager, only : operator(-), set_time -use MOM_time_manager, only : operator(<=), time_type ! for testing itides (BDM) +use MOM_time_manager, only : time_type, real_to_time_type, operator(-), operator(<=) use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS use MOM_tracer_diabatic, only : tracer_vertdiff use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs @@ -440,7 +439,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) + call enable_averaging(0.5*dt, Time_end - real_to_time_type(0.5*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -1316,7 +1315,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) + call enable_averaging(0.5*dt, Time_end - real_to_time_type(0.5*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 26a23a0f0d..ca2afdc655 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -5,7 +5,6 @@ module MOM_opacity use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field -use MOM_time_manager, only : get_time use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase @@ -225,7 +224,6 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) ! radiation, in W m-2. type(time_type) :: day character(len=128) :: mesg - integer :: days, seconds integer :: i, j, k, n, is, ie, js, je, nz, nbands logical :: multiband_vis_input, multiband_nir_input @@ -271,7 +269,6 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) else ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. - call get_time(CS%Time,seconds,days) call time_interp_external(CS%sbc_chl, CS%Time, chl_data) do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_data(i,j) < 0.0)) then diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 91b156751f..0354f90a51 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -15,7 +15,7 @@ module DOME_tracer use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 40e8ef6db5..0707b54fb3 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -20,7 +20,7 @@ module ISOMIP_tracer use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index e8c3387cea..ebff38508c 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -14,7 +14,7 @@ module MOM_OCMIP2_CFC use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index d06ffe0e2c..66dd26fca0 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -35,7 +35,7 @@ module MOM_generic_tracer use MOM_spatial_means, only : global_area_mean use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS - use MOM_time_manager, only : time_type, get_time, set_time + use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_Z_init, only : tracer_Z_init diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 4ed395bac8..aeb1b3aae9 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -14,7 +14,7 @@ module advection_test_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 7995b712e3..9b785fe41d 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -14,7 +14,7 @@ module boundary_impulse_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index a597b1fc8c..0e1b9a06b9 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -14,7 +14,7 @@ module regional_dyes use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 2102f1cc71..af69a39c52 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -13,7 +13,7 @@ module dyed_obc_tracer use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 1f77bd639e..d7fcb53324 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -14,7 +14,7 @@ module ideal_age_example use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init @@ -317,7 +317,6 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, real :: sfc_val ! The surface value for the tracers. real :: Isecs_per_year ! The number of seconds in a year. real :: year ! The time in years. - integer :: secs, days ! Integer components of the time type. integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -342,8 +341,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, Isecs_per_year = 1.0 / (365.0*86400.0) ! Set the surface value of tracer 1 to increase exponentially ! with a 30 year time scale. - call get_time(CS%Time, secs, days) - year = (86400.0*days + real(secs)) * Isecs_per_year + year = time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr if (CS%sfc_growth_rate(m) == 0.0) then diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index fd794aff0b..3b98c19a73 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -14,7 +14,7 @@ module oil_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init @@ -334,7 +334,6 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: Isecs_per_year = 1.0 / (365.0*86400.0) real :: year, h_total, ldecay - integer :: secs, days integer :: i, j, k, is, ie, js, je, nz, m, k_max is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -356,10 +355,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS enddo endif - ! Set the surface value of tracer 1 to increase exponentially - ! with a 30 year time scale. - call get_time(CS%Time, secs, days) - year = (86400.0*days + real(secs)) * Isecs_per_year + year = time_type_to_real(CS%Time) * Isecs_per_year ! Decay tracer (limit decay rate to 1/dt - just in case) do m=2,CS%ntr diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index fb0d38d86a..d9f4d3f682 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -16,7 +16,7 @@ module pseudo_salt_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 966fa07410..bf6b504658 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -14,7 +14,7 @@ module USER_tracer_example use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 27168618be..edcdb002cf 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -12,7 +12,7 @@ module BFB_surface_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index eeda2e267f..8cf56a42ac 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -17,7 +17,7 @@ module Kelvin_initialization use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_registry_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real implicit none ; private diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index c361a37176..05ea1edd88 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -18,8 +18,8 @@ module MOM_controlled_forcing use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) -use MOM_time_manager, only : get_time, get_date, set_time, set_date -use MOM_time_manager, only : time_type_to_real +use MOM_time_manager, only : get_date, set_date +use MOM_time_manager, only : time_type_to_real, real_to_time_type use MOM_variables, only : surface implicit none ; private @@ -121,7 +121,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec if (.not.associated(CS)) return if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return - day_end = day_start + set_time(floor(dt+0.5)) + day_end = day_start + real_to_time_type(dt) do j=js,je ; do i=is,ie virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 950fe4729d..5a1be3f50b 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -12,8 +12,8 @@ module MOM_wave_interface use MOM_grid, only : ocean_grid_type use MOM_verticalgrid, only : verticalGrid_type use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time,& - time_type_to_real,real_to_time_type +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_time_manager, only : time_type_to_real, real_to_time_type use MOM_variables, only : thermo_var_ptrs, surface use data_override_mod, only : data_override_init, data_override diff --git a/src/user/SCM_CVmix_tests.F90 b/src/user/SCM_CVmix_tests.F90 index 2f2026c848..fca5ffa1d2 100644 --- a/src/user/SCM_CVmix_tests.F90 +++ b/src/user/SCM_CVmix_tests.F90 @@ -8,11 +8,10 @@ module SCM_CVMix_tests use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_verticalgrid, only: verticalGrid_type +use MOM_verticalgrid, only : verticalGrid_type use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time,& - time_type_to_real -use MOM_variables, only : thermo_var_ptrs, surface +use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real +use MOM_variables, only : thermo_var_ptrs, surface implicit none ; private #include diff --git a/src/user/SCM_idealized_hurricane.F90 b/src/user/SCM_idealized_hurricane.F90 index f688c40ec6..2bb04b30f9 100644 --- a/src/user/SCM_idealized_hurricane.F90 +++ b/src/user/SCM_idealized_hurricane.F90 @@ -10,8 +10,7 @@ module SCM_idealized_hurricane use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time,& - time_type_to_real +use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 0718ceb09c..d206914e2a 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -162,6 +162,7 @@ subroutine dumbbell_dynamic_forcing(state, fluxes, day, dt, G, CS) call get_time(day,isecs,idays) rdays = real(idays) + real(isecs)/8.64e4 + ! This could be: rdays = time_type_to_real(day)/8.64e4 ! Allocate and zero out the forcing arrays, as necessary. call safe_alloc_ptr(fluxes%p_surf, isd, ied, jsd, jed) diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 133b5388cb..cb1b9a6b2f 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -11,7 +11,7 @@ module dyed_channel_initialization use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_open_boundary, only : OBC_registry_type, register_OBC -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type use MOM_variables, only : thermo_var_ptrs diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 1640c9ec5a..9207830032 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -11,7 +11,7 @@ module shelfwave_initialization use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real implicit none ; private diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 6b10664d57..f12378c3d9 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -9,7 +9,7 @@ module supercritical_initialization use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE, OBC_segment_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real implicit none ; private diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 7726dbf171..161ad25c11 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -13,7 +13,7 @@ module tidal_bay_initialization use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real implicit none ; private diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index f2e381cc4a..d1be729734 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -10,7 +10,7 @@ module user_revise_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data use MOM_restart, only : register_restart_field, MOM_restart_CS -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface From 5f6384cbeb921dea08b44fcaca336f523c9b7420 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Aug 2018 16:25:09 -0400 Subject: [PATCH 28/37] (*)Corrected time units in MOM6 restart files The previous commit wrote and read the real time written to the restart files in seconds, not units of days (86400 seconds) as was traditionally done. This meant that while the restarts were internally consistent, they were incompatible with the restart files from any other versions of MOM6. The real times written to and read from the restart files have been reverted to be in days (i.e. 86400 seconds). All answers are bitwise identical. --- src/framework/MOM_restart.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 436d514125..e491c297aa 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -808,7 +808,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) next_var = 0 nz = 1 ; if (present(GV)) nz = GV%ke - restart_time = time_type_to_real(time) + restart_time = time_type_to_real(time) / 86400.0 restartname = trim(CS%restartfile) if (present(filename)) restartname = trim(filename) @@ -1027,7 +1027,7 @@ subroutine restore_state(filename, directory, day, G, CS) t1 = time_vals(1) deallocate(time_vals) - day = real_to_time_type(t1) + day = real_to_time_type(t1*86400.0) exit enddo From f579e9ee1d8a27f7ddc7535bca003213aaf0ce84 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Aug 2018 10:41:18 -0400 Subject: [PATCH 29/37] +(*)Add real_to_time Added an alternate implementation of the FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit signed integers, this new version should work over the entire valid range (2^31 days or ~5.8835 million years) of time_types, whereas the standard version in the FMS time_manager stops working correctly for conversions of times greater than 2^31 seconds (~68.1 years). At some point the FMS version should be upgraded, at which point real_to_time could become a wrapper to the FMS version. All answers in the test cases are bitwise identical, but there is a new public interface. --- src/framework/MOM_time_manager.F90 | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_time_manager.F90 b/src/framework/MOM_time_manager.F90 index 25c367c1ef..229c3ded3a 100644 --- a/src/framework/MOM_time_manager.F90 +++ b/src/framework/MOM_time_manager.F90 @@ -20,8 +20,9 @@ module MOM_time_manager implicit none ; private -public :: time_type, get_time, set_time, time_type_to_real, real_to_time_type -public :: set_ticks_per_second , get_ticks_per_second +public :: time_type, get_time, set_time +public :: time_type_to_real, real_to_time_type, real_to_time +public :: set_ticks_per_second, get_ticks_per_second public :: operator(+), operator(-), operator(*), operator(/) public :: operator(>), operator(<), operator(>=), operator(<=) public :: operator(==), operator(/=), operator(//) @@ -35,4 +36,29 @@ module MOM_time_manager public :: get_external_field_axes public :: get_external_field_missing +contains + +!> This is an alternate implementation of the FMS function real_to_time_type that is accurate over +!! a larger range of input values. With 32 bit signed integers, this version should work over the +!! entire valid range (2^31 days or ~5.8835 million years) of time_types, whereas the standard +!! version in the FMS time_manager stops working for conversions of times greater than 2^31 seconds, +!! or ~68.1 years. +function real_to_time(x, err_msg) + type(time_type) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), intent(out), optional :: err_msg !< An optional returned error message. + + ! Local variables + integer :: seconds, days, ticks + real :: real_subsecond_remainder + + days = floor(x/86400.) + seconds = floor(x - 86400.*days) + real_subsecond_remainder = x - (days*86400. + seconds) + ticks = nint(real_subsecond_remainder * get_ticks_per_second()) + + real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) +end function real_to_time + + end module MOM_time_manager From 97479d85f5745716d9e519173ba4b84fa2fcf513 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Aug 2018 10:54:41 -0400 Subject: [PATCH 30/37] (*)Use real_to_time Use the new function real_to_time in place of the equivalent FMS function real_to_time_type throughout the MOM6 code. In some cases, the module use statements needed to be change dto go via the MOM_time_manager, rather than directly to the FMS time_manager_mod. All answers in the test cases are bitwise identical, and any problems with long times due to the previous commit using real_to_time_type should be averted. --- src/core/MOM.F90 | 34 +++++++++---------- src/core/MOM_barotropic.F90 | 6 ++-- src/core/MOM_dynamics_unsplit.F90 | 4 +-- src/framework/MOM_file_parser.F90 | 6 ++-- src/framework/MOM_restart.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf.F90 | 6 ++-- .../vertical/MOM_diabatic_driver.F90 | 6 ++-- src/user/MOM_controlled_forcing.F90 | 4 +-- src/user/MOM_wave_interface.F90 | 1 - 9 files changed, 35 insertions(+), 36 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bf47d7b08c..cccc460751 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -39,7 +39,7 @@ module MOM use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral -use MOM_time_manager, only : time_type, real_to_time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_time_manager, only : operator(>=), increment_date use MOM_unit_tests, only : unit_tests @@ -556,7 +556,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo if (associated(CS%VarMix)) then - call enable_averaging(cycle_time, Time_start + real_to_time_type(cycle_time), & + call enable_averaging(cycle_time, Time_start + real_to_time(cycle_time), & CS%diag) call calc_resoln_function(h, CS%tv, G, GV, CS%VarMix) call disable_averaging(CS%diag) @@ -582,7 +582,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom - call enable_averaging(time_interval, Time_start + real_to_time_type(time_interval), CS%diag) + call enable_averaging(time_interval, Time_start + real_to_time(time_interval), CS%diag) call Update_Stokes_Drift(G, GV, Waves, h, forces%ustar) call disable_averaging(CS%diag) endif @@ -604,9 +604,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do n=1,n_max rel_time = rel_time + dt ! The relative time at the end of the step. ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) ! Set the local time to the end of the time step. - Time_local = Time_start + real_to_time_type(rel_time) + Time_local = Time_start + real_to_time(rel_time) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -633,10 +633,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (dtdia > dt) then ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they begin at the same time. - CS%Time = CS%Time + real_to_time_type(0.5*(dtdia-dt)) + CS%Time = CS%Time + real_to_time(0.5*(dtdia-dt)) ! The end-time of the diagnostic interval needs to be set ahead if there ! are multiple dynamic time steps worth of thermodynamics applied here. - end_time_thermo = Time_local + real_to_time_type(dtdia-dt) + end_time_thermo = Time_local + real_to_time(dtdia-dt) endif ! Apply diabatic forcing, do mixing, and regrid. @@ -649,7 +649,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then @@ -731,7 +731,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - if (dtdia > dt) CS%Time = CS%Time - real_to_time_type(0.5*(dtdia-dt)) + if (dtdia > dt) CS%Time = CS%Time - real_to_time(0.5*(dtdia-dt)) ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & @@ -740,7 +740,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%t_dyn_rel_thermo = 0.0 if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + real_to_time_type(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) endif if (do_dyn) then @@ -774,7 +774,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%t_dyn_rel_diag = 0.0 call cpu_clock_begin(id_clock_Z_diag) - if (Time_local + real_to_time_type(0.5*dt_therm) > CS%Z_diag_time) then + if (Time_local + real_to_time(0.5*dt_therm) > CS%Z_diag_time) then call enable_averaging(real(time_type_to_real(CS%Z_diag_interval)), & CS%Z_diag_time, CS%diag) !### This is the one place where fluxes might used if do_thermo=.false. Is this correct? @@ -852,7 +852,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & G, GV, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=real_to_time_type(time_interval) ) + dt_forcing=real_to_time(time_interval) ) call cpu_clock_end(id_clock_other) @@ -912,7 +912,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo, Time_local+real_to_time_type(dt_thermo-dt), CS%diag) + call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) @@ -931,7 +931,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then call enable_averaging(bbl_time_int, & - Time_local + real_to_time_type(bbl_time_int-dt), CS%diag) + Time_local + real_to_time(bbl_time_int-dt), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, & @@ -2286,7 +2286,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = real_to_time_type(CS%dtbt_reset_period) + CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & ((Time - Time_init) / CS%dtbt_reset_interval) @@ -2325,10 +2325,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & param_file, diag, CS%diagnostics_CSp, CS%tv) call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) - CS%Z_diag_interval = real_to_time_type(CS%dt_therm * max(1,floor(0.01 + Z_diag_int/CS%dt_therm))) + CS%Z_diag_interval = real_to_time(CS%dt_therm * max(1,floor(0.01 + Z_diag_int/CS%dt_therm))) call MOM_diag_to_Z_init(Time, G, GV, param_file, diag, CS%diag_to_Z_CSp) CS%Z_diag_time = Start_time + CS%Z_diag_interval * (1 + & - ((Time + real_to_time_type(CS%dt_therm)) - Start_time) / CS%Z_diag_interval) + ((Time + real_to_time(CS%dt_therm)) - Start_time) / CS%Z_diag_interval) if (associated(CS%sponge_CSp)) & call init_sponge_diags(Time, G, diag, CS%sponge_CSp) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c423b2d0c1..674f6f1bff 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -22,7 +22,7 @@ module MOM_barotropic use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS -use MOM_time_manager, only : time_type, real_to_time_type, operator(+), operator(-) +use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -723,7 +723,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) & - time_bt_start = time_end_in - real_to_time_type(dt) + time_bt_start = time_end_in - real_to_time(dt) endif !--- begin setup for group halo update @@ -2008,7 +2008,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & enddo ; enddo if (do_hifreq_output) then - time_step_end = time_bt_start + real_to_time_type(n*dtbt) + time_step_end = time_bt_start + real_to_time(n*dtbt) call enable_averaging(dtbt, time_step_end, CS%diag) if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 506dd3624b..3965758510 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -72,7 +72,7 @@ module MOM_dynamics_unsplit use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_time_manager, only : time_type, real_to_time_type, operator(+) +use MOM_time_manager, only : time_type, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS @@ -267,7 +267,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averaging(0.5*dt,Time_local-real_to_time_type(0.5*dt), CS%diag) + call enable_averaging(0.5*dt,Time_local-real_to_time(0.5*dt), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 70f3b9a941..72944c4f7a 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -7,7 +7,7 @@ module MOM_file_parser use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_error_handler, only : is_root_pe, stdlog, stdout use MOM_time_manager, only : get_time, time_type, get_ticks_per_second -use MOM_time_manager, only : set_date, get_date, real_to_time_type +use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time use MOM_document, only : doc_param, doc_module, doc_init, doc_end, doc_type use MOM_document, only : doc_openBlock, doc_closeBlock use MOM_string_functions, only : left_int, left_ints, slasher @@ -854,8 +854,8 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f else time_unit = 1.0 ; if (present(timeunit)) time_unit = timeunit read( value_string(1), *) real_time - value = real_to_time_type(real_time*time_unit) - endif + value = real_to_time(real_time*time_unit) + endif else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index e491c297aa..8d5819f945 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -14,7 +14,7 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_time_manager, only : time_type, time_type_to_real, real_to_time_type +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date use MOM_verticalGrid, only : verticalGrid_type use mpp_mod, only: mpp_chksum @@ -1027,7 +1027,7 @@ subroutine restore_state(filename, directory, day, G, CS) t1 = time_vals(1) deallocate(time_vals) - day = real_to_time_type(t1*86400.0) + day = real_to_time(t1*86400.0) exit enddo diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 7e3c4ac606..e6989caa54 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -25,7 +25,7 @@ module MOM_ice_shelf use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real, time_type_to_real, real_to_time use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_variables, only : surface use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum @@ -47,7 +47,7 @@ module MOM_ice_shelf use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time, time_type_to_real, real_to_time_type +use time_manager_mod, only : print_time implicit none ; private #include @@ -979,7 +979,7 @@ subroutine add_shelf_flux(G, CS, state, fluxes) ! just compute changes in mass after first time step if (t0>0.0) then - Time0 = real_to_time_type(t0) + Time0 = real_to_time(t0) last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) last_h_shelf = last_mass_shelf/CS%density_ice diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 846e27de8b..e3806fd684 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -61,7 +61,7 @@ module MOM_diabatic_driver use MOM_shortwave_abs, only : absorbRemainingSW, optics_type use MOM_sponge, only : apply_sponge, sponge_CS use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS -use MOM_time_manager, only : time_type, real_to_time_type, operator(-), operator(<=) +use MOM_time_manager, only : time_type, real_to_time, operator(-), operator(<=) use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS use MOM_tracer_diabatic, only : tracer_vertdiff use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs @@ -439,7 +439,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - real_to_time_type(0.5*dt), CS%diag) + call enable_averaging(0.5*dt, Time_end - real_to_time(0.5*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -1315,7 +1315,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - real_to_time_type(0.5*dt), CS%diag) + call enable_averaging(0.5*dt, Time_end - real_to_time(0.5*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 05ea1edd88..2034a16bb4 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -19,7 +19,7 @@ module MOM_controlled_forcing use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) use MOM_time_manager, only : get_date, set_date -use MOM_time_manager, only : time_type_to_real, real_to_time_type +use MOM_time_manager, only : time_type_to_real, real_to_time use MOM_variables, only : surface implicit none ; private @@ -121,7 +121,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec if (.not.associated(CS)) return if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return - day_end = day_start + real_to_time_type(dt) + day_end = day_start + real_to_time(dt) do j=js,je ; do i=is,ie virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 5a1be3f50b..c8ce37ad55 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -13,7 +13,6 @@ module MOM_wave_interface use MOM_verticalgrid, only : verticalGrid_type use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) -use MOM_time_manager, only : time_type_to_real, real_to_time_type use MOM_variables, only : thermo_var_ptrs, surface use data_override_mod, only : data_override_init, data_override From dba64e84b02cb9e0174dcaacb9881c2139c2f15e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 15 Aug 2018 14:14:29 -0800 Subject: [PATCH 31/37] Fix to soliton initialization. - Now seems to work with PR #833. --- src/user/soliton_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index c9e7eec40e..6f4b2898c5 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -53,7 +53,7 @@ subroutine soliton_initialize_thickness(h, G, GV) y = G%geoLatT(i,j)-y0 val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) - h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) + h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) + G%bathyT(i,j) enddo enddo ; enddo From 22fbe6f3ae20f84da850e5f87438f72a1d9813d3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 15 Aug 2018 14:19:56 -0800 Subject: [PATCH 32/37] Fix soliton initialization with GV%m_to_H --- src/user/soliton_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 6f4b2898c5..e258b87bf1 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -53,7 +53,7 @@ subroutine soliton_initialize_thickness(h, G, GV) y = G%geoLatT(i,j)-y0 val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) - h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) + G%bathyT(i,j) + h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y) + G%bathyT(i,j)) enddo enddo ; enddo From 731f2cfb72b0b8e5129aed752406ce6535608889 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Aug 2018 18:23:12 -0400 Subject: [PATCH 33/37] Eliminated unused variables in forcing modules Eliminated unused variables, duplicate comment blocks, and module use statements for get_time. All answers are bitwise identical. --- .../solo_driver/Neverland_surface_forcing.F90 | 42 ++++++++--------- .../solo_driver/user_surface_forcing.F90 | 45 +++---------------- 2 files changed, 26 insertions(+), 61 deletions(-) diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 65a5ca1339..e6111b2a19 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -12,7 +12,7 @@ module Neverland_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_variables, only : surface implicit none ; private @@ -48,15 +48,15 @@ module Neverland_surface_forcing !! Neverland forcing configuration. subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. + !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - ! Local variable + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. + + ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: x, y real :: PI real :: tau_max, off @@ -110,26 +110,26 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) end subroutine Neverland_wind_forcing !> Returns the value of a cosine-bell function evaluated at x/L - real function cosbell(x,L) +real function cosbell(x,L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: PI !< 3.1415926... calculated as 4*atan(1) - PI = 4.0*atan(1.0) - cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) - end function cosbell + PI = 4.0*atan(1.0) + cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) +end function cosbell !> Returns the value of a sin-spike function evaluated at x/L - real function spike(x,L) +real function spike(x,L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: PI !< 3.1415926... calculated as 4*atan(1) - PI = 4.0*atan(1.0) - spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) - end function spike + PI = 4.0*atan(1.0) + spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) +end function spike !> Surface fluxes of buoyancy for the Neverland configurations. diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index e0136abf0f..7a27c75e18 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -12,7 +12,7 @@ module user_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface @@ -49,30 +49,15 @@ module user_surface_forcing !! direction as the u- and v- velocities.) They are both in Pa. subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. + !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned !! by a previous call to user_surface_forcing_init -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. -! These are the stresses in the direction of the model grid (i.e. the same -! direction as the u- and v- velocities.) They are both in Pa. -! In addition, this subroutine can be used to set the surface friction -! velocity, forces%ustar, in m s-1. This is needed with a bulk mixed layer. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init - + ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. @@ -81,8 +66,6 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) @@ -138,22 +121,12 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init - + ! Local variables real :: Temp_restore ! The temperature that is being restored toward, in C. real :: Salin_restore ! The salinity that is being restored toward, in PSU. real :: density_restore ! The potential density that is being restored ! toward, in kg m-3. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux, in m5 s-3 kg-1. @@ -266,14 +239,6 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to !! the control structure for this module -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "user_surface_forcing" ! This module's name. From 904b5fe9b954304bb2537f711a20c9baaaa178d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Aug 2018 18:24:42 -0400 Subject: [PATCH 34/37] +Removed MESO_wind_forcing MESO_wind_forcing was never actually being used, so I eliminated it and removed the call to it from set_forcing. Also eliminated unused variables and simplified the code converting day_interval to dt in set_forcing. Duplicate comment blocks were also eliminated in MESO_forcing.F90. All answers are bitwise identical. --- .../solo_driver/MESO_surface_forcing.F90 | 95 +------------------ .../solo_driver/MOM_surface_forcing.F90 | 33 ++----- 2 files changed, 9 insertions(+), 119 deletions(-) diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index eaa11da6c1..68852f89d9 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -12,14 +12,14 @@ module MESO_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface implicit none ; private -public MESO_wind_forcing, MESO_buoyancy_forcing, MESO_surface_forcing_init +public MESO_buoyancy_forcing, MESO_surface_forcing_init !> This control structure is used to store parameters associated with the MESO forcing. type, public :: MESO_surface_forcing_CS ; private @@ -52,71 +52,6 @@ module MESO_surface_forcing contains -!### This subroutine sets zero surface wind stresses, but it is not even -!### used by the MESO experimeents. This subroutine can be deleted. -RWH -subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< The time of the fluxes - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a previous - !! call to MESO_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. -! These are the stresses in the direction of the model grid (i.e. the same -! direction as the u- and v- velocities.) They are both in Pa. -! In addition, this subroutine can be used to set the surface friction -! velocity, forces%ustar, in m s-1. This is needed with a bulk mixed layer. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to MESO_surface_forcing_init - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "MESO_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses, in units of Pa. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity, in units of m s-1. ustar - ! is always positive. - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) - enddo ; enddo ; endif - -end subroutine MESO_wind_forcing - !> This subroutine sets up the MESO buoyancy forcing, which uses control-theory style !! specification restorative buoyancy fluxes at large scales. subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) @@ -130,10 +65,6 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by !! a previous call to MESO_surface_forcing_init -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - ! When temperature is used, there are long list of fluxes that need to be ! set - essentially the same as for a full coupled model, but most of these ! can be simply set to zero. The net fresh water flux should probably be @@ -144,17 +75,6 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to MESO_surface_forcing_init - real :: Temp_restore ! The temperature that is being restored toward, in C. real :: Salin_restore ! The salinity that is being restored toward, in PSU. real :: density_restore ! The potential density that is being restored @@ -293,14 +213,6 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) type(MESO_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MESO_surface_forcing" ! This module's name. @@ -383,9 +295,6 @@ end subroutine MESO_surface_forcing_init !! it is probably a good idea to read the forcing from input files !! using "file" for WIND_CONFIG and BUOY_CONFIG. !! -!! MESO_wind_forcing should set the surface wind stresses (taux and -!! tauy) perhaps along with the surface friction velocity (ustar). -!! !! MESO_buoyancy forcing is used to set the surface buoyancy !! forcing, which may include a number of fresh water flux fields !! (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 351b149830..a3a9a12204 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -32,11 +32,11 @@ module MOM_surface_forcing use MOM_io, only : EAST_FACE, NORTH_FACE, num_timelevels use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time +use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, time_type_to_real use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface -use MESO_surface_forcing, only : MESO_wind_forcing, MESO_buoyancy_forcing +use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS use Neverland_surface_forcing, only : Neverland_wind_forcing, Neverland_buoyancy_forcing use Neverland_surface_forcing, only : Neverland_surface_forcing_init, Neverland_surface_forcing_CS @@ -226,7 +226,6 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS ! Local variables real :: dt ! length of time in seconds over which fluxes applied type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -234,8 +233,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS call callTree_enter("set_forcing, MOM_surface_forcing.F90") day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) + dt = time_type_to_real(day_interval) if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodyanmic forcing fields. @@ -275,8 +273,6 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, CS) elseif (trim(CS%wind_config) == "const") then call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) elseif (trim(CS%wind_config) == "Neverland") then call Neverland_wind_forcing(sfc_state, forces, day_center, G, CS%Neverland_forcing_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -369,13 +365,10 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) ! Local variables real :: mag_tau integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB !set steady surface wind stresses, in units of Pa. mag_tau = sqrt( tau_x0**2 + tau_y0**2) @@ -414,13 +407,10 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB !set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) @@ -450,13 +440,10 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) @@ -484,25 +471,22 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) ! Local variables real :: PI, y integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! steady surface wind stresses (Pa) PI = 4.0*atan(1.0) - do j=jsd,jed ; do I=is-1,IedB + do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat forces%taux(I,j) = CS%gyres_taux_const + & ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) enddo ; enddo - do J=js-1,JedB ; do i=isd,ied + do J=js-1,Jeq ; do i=is-1,ie+1 forces%tauy(i,J) = 0.0 enddo ; enddo @@ -535,16 +519,13 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) integer :: time_lev ! The time level that is used for a field. integer :: days, seconds integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB logical :: read_Ustar call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - call get_time(day,seconds,days) + call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 @@ -774,7 +755,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) Irho0 = 1.0/CS%Rho0 ! Read the buoyancy forcing file - call get_time(day,seconds,days) + call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) From 396e19348e20764b07f402db17be293615d4bb4c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Aug 2018 18:25:30 -0400 Subject: [PATCH 35/37] (*)Use real_to_time in driver code Replaced real_to_time_type with real_to_time in the coupled and ocean-only driver code to avoid problems when converting large times. All answers are bitwise identical in the test cases. --- config_src/coupled_driver/ocean_model_MOM.F90 | 6 +++--- config_src/solo_driver/MOM_driver.F90 | 20 +++++++++---------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 742688506f..70437d0e4c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -40,7 +40,7 @@ module ocean_model_mod use MOM_time_manager, only : time_type, operator(>), operator(+), operator(-) use MOM_time_manager, only : operator(*), operator(/), operator(/=) use MOM_time_manager, only : operator(<=), operator(>=), operator(<) -use MOM_time_manager, only : real_to_time_type, time_type_to_real +use MOM_time_manager, only : real_to_time, time_type_to_real use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_variables, only : surface @@ -600,7 +600,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. - Time1 = Time1 - real_to_time_type(dtdia - dt_dyn) + Time1 = Time1 - real_to_time(dtdia - dt_dyn) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -608,7 +608,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time1 = Time_seg_start + real_to_time_type(t_elapsed_seg) + Time1 = Time_seg_start + real_to_time(t_elapsed_seg) enddo endif diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index da0f77d935..4933f29182 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -48,8 +48,8 @@ program MOM_main use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date - use MOM_time_manager, only : real_to_time_type, time_type_to_real + use MOM_time_manager, only : time_type, set_date, get_date + use MOM_time_manager, only : real_to_time, time_type_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name @@ -291,7 +291,7 @@ program MOM_main Start_time = set_date(date_init(1),date_init(2), date_init(3), & date_init(4),date_init(5),date_init(6)) else - Start_time = set_time(0,days=0) + Start_time = real_to_time(0.0) endif call time_interp_external_init @@ -357,7 +357,7 @@ program MOM_main endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = real_to_time_type(dt_forcing) + Time_step_ocean = real_to_time(dt_forcing) elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) @@ -416,7 +416,7 @@ program MOM_main call get_param(param_file, mod_name, "RESTINT", restint, & "The interval between saves of the restart file in units \n"//& "of TIMEUNIT. Use 0 (the default) to not save \n"//& - "incremental restart files at all.", default=set_time(0), & + "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & "The number of coupled timesteps between writing the cpu \n"//& @@ -455,7 +455,7 @@ program MOM_main if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. - if (restint > set_time(0)) then + if (restint > real_to_time(0.0)) then ! restart_time is the next integral multiple of restint. restart_time = Start_time + restint * & (1 + ((Time + Time_step_ocean) - Start_time) / restint) @@ -533,7 +533,7 @@ program MOM_main dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - real_to_time_type(dtdia - dt_dyn) + Time2 = Time2 - real_to_time(dtdia - dt_dyn) call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) @@ -542,7 +542,7 @@ program MOM_main endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + real_to_time_type(t_elapsed_seg) + Time2 = Time1 + real_to_time(t_elapsed_seg) enddo endif @@ -555,12 +555,12 @@ program MOM_main ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time_type(elapsed_time) + time_chg = real_to_time(elapsed_time) segment_start_time = segment_start_time + time_chg elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time_type(elapsed_time) + Master_Time = segment_start_time + real_to_time(elapsed_time) else Master_Time = Master_Time + Time_step_ocean endif From 9252394b1f5605b911b09de86fc065a8f5b47713 Mon Sep 17 00:00:00 2001 From: Raymond Menzel Date: Tue, 21 Aug 2018 14:31:20 -0400 Subject: [PATCH 36/37] Reordered loops to address a bug when compiled with -O3 using the intel compiler version 16.0.3.210 --- .../vertical/MOM_vert_friction.F90 | 55 ++++++++++--------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 88da20bb4d..c345818493 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -217,14 +217,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & Idt = 1.0 / dt !Check if Stokes mixing allowed if requested (present and associated) + DoStokesMixing=.false. if (CS%StokesMixing) then - DoStokesMixing=(present(Waves) .and. associated(Waves)) - if (.not.DoStokesMixing) then - call MOM_error(FATAL,"Stokes Mixing called without allocated"//& - "Waves Control Structure") + if (present(Waves)) then + DoStokesMixing = associated(Waves) + if (.not. DoStokesMixing) then + call MOM_error(FATAL,"Stokes Mixing called without allocated"//& + "Waves Control Structure") + endif endif - else - DoStokesMixing=.false. endif do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo @@ -232,17 +233,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & ! Update the zonal velocity component using a modification of a standard ! tridagonal solver. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq - if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) - enddo ; enddo ; enddo ; endif - !$OMP parallel do default(shared) firstprivate(Ray) & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do j=G%jsc,G%jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + enddo ; enddo ; endif + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif @@ -330,19 +331,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & taux_bot(I,j) = taux_bot(I,j) + Rho0 * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif - enddo ! end u-component j loop - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq - if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) - enddo ; enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + enddo ; enddo ; endif + + enddo ! end u-component j loop ! Now work on the meridional velocity component. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=Jsq,Jeq ; do I=Is,Ie - if (G%mask2dCv(I,j) > 0) & - v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) - enddo ; enddo ; enddo ; endif !$OMP parallel do default(shared) firstprivate(Ray) & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & @@ -350,6 +347,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + enddo ; enddo ; endif + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif @@ -411,12 +413,13 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & tauy_bot(i,J) = tauy_bot(i,J) + Rho0 * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif - enddo ! end of v-component J loop - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=Is,Ie - if (G%mask2dCv(i,J) > 0) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) - enddo ; enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + enddo ; enddo ; endif + + enddo ! end of v-component J loop call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) From e3ea419953d49623653c7f277389aefc424742d6 Mon Sep 17 00:00:00 2001 From: Raymond Menzel Date: Tue, 21 Aug 2018 15:31:03 -0400 Subject: [PATCH 37/37] Fixed logic, made ifs one-liners. --- src/parameterizations/vertical/MOM_vert_friction.F90 | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c345818493..6b5fcb3202 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -219,13 +219,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & !Check if Stokes mixing allowed if requested (present and associated) DoStokesMixing=.false. if (CS%StokesMixing) then - if (present(Waves)) then - DoStokesMixing = associated(Waves) - if (.not. DoStokesMixing) then - call MOM_error(FATAL,"Stokes Mixing called without allocated"//& - "Waves Control Structure") - endif - endif + if (present(Waves)) DoStokesMixing = associated(Waves) + if (.not. DoStokesMixing) & + call MOM_error(FATAL,"Stokes Mixing called without allocated"//& + "Waves Control Structure") endif do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo