diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 57eb9cfcbc..51d3e0c7b7 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -1413,9 +1413,8 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & "If true, allows flux adjustments to specified via the \n"//& "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) - endif + + call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9ac616dac0..7d27841311 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2133,7 +2133,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%frunoff)) res(i,j) = res(i,j)+fluxes%frunoff(i,j) if (associated(fluxes%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) enddo ; enddo - call post_data(handles%id_prcme, res, diag) + if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_prcme, total_transport, diag) @@ -2151,7 +2151,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo - call post_data(handles%id_net_massout, res, diag) + if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massout, total_transport, diag) @@ -2168,7 +2168,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) ! fluxes%cond is not needed because it is derived from %evap > 0 if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo - call post_data(handles%id_net_massin, res, diag) + if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massin, total_transport, diag) @@ -2322,7 +2322,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) enddo ; enddo - call post_data(handles%id_net_heat_coupler, res, diag) + if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) @@ -2382,7 +2382,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) ! endif enddo ; enddo - call post_data(handles%id_heat_content_surfwater, res, diag) + if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index eea4874f4e..62ac6e1ea4 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -143,7 +143,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG) call pass_vector(oG%geoLatCu, oG%geoLatCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_var(oG%areaBu, oG%Domain, position=CORNER) - call pass_var(oG%geoLonBu, oG%Domain, position=CORNER) + call pass_var(oG%geoLonBu, oG%Domain, position=CORNER, inner_halo=oG%isc-isd) call pass_var(oG%geoLatBu, oG%Domain, position=CORNER) call pass_vector(oG%dxBu, oG%dyBu, oG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(oG%CoriolisBu, oG%Domain, position=CORNER) @@ -287,7 +287,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG) call pass_vector(dG%geoLatCu, dG%geoLatCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_var(dG%areaBu, dG%Domain, position=CORNER) - call pass_var(dG%geoLonBu, dG%Domain, position=CORNER) + call pass_var(dG%geoLonBu, dG%Domain, position=CORNER, inner_halo=dG%isc-isd) call pass_var(dG%geoLatBu, dG%Domain, position=CORNER) call pass_vector(dG%dxBu, dG%dyBu, dG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(dG%CoriolisBu, dG%Domain, position=CORNER) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index a38facf79a..a43a392963 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -27,18 +27,18 @@ module MOM_domains use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent use mpp_parameter_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE -use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER use fms_io_mod, only : file_exist, parse_mask_table implicit none ; private public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain -public :: pass_var, pass_vector, broadcast, PE_here, root_PE, num_PEs -public :: pass_var_start, pass_var_complete, fill_symmetric_edges +public :: pass_var, pass_vector, PE_here, root_PE, num_PEs +public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass @@ -178,8 +178,7 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & end subroutine pass_var_3d !> pass_var_2d does a halo update for a two-dimensional array. -subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & - clock) +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points !! exchanged. type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain @@ -197,9 +196,18 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & !! by default. integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo !! by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn integer :: dirflag logical :: block_til_complete @@ -207,8 +215,15 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & dirflag = To_All ! 60 if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - block_til_complete = .true. - if (present(complete)) block_til_complete = complete + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif if (present(halo) .and. MOM_dom%thin_halo_updates) then call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & @@ -219,6 +234,46 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & complete=block_til_complete, position=position) endif + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif end subroutine pass_var_2d diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 9f7c5dcc28..70039bcb98 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -183,6 +183,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" integer :: err=0, ni, nj, global_indices(4) type(MOM_domain_type) :: SGdom ! Supergrid domain + logical :: lon_bug ! If true use an older buggy answer in the tripolar longitude. integer :: i, j, i2, j2 integer :: npei,npej integer, dimension(:), allocatable :: exni,exnj @@ -193,6 +194,10 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) call get_param(param_file, mdl, "GRID_FILE", grid_file, & "Name of the file from which to read horizontal grid data.", & fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_TRIPOLAR_GEOLONB_BUG", lon_bug, & + "If true, use older code that incorrectly sets the longitude \n"//& + "in some points along the tripolar fold to be off by 360 degrees.", & + default=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) filename = trim(adjustl(inputdir)) // trim(adjustl(grid_file)) @@ -248,7 +253,11 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) tmpZ(:,:) = 999. call MOM_read_data(filename, 'x', tmpZ, SGdom, position=CORNER) - call pass_var(tmpZ, SGdom, position=CORNER) + if (lon_bug) then + call pass_var(tmpZ, SGdom, position=CORNER) + else + call pass_var(tmpZ, SGdom, position=CORNER, inner_halo=0) + endif call extrapolate_metric(tmpZ, 2*(G%jsc-G%jsd)+2, missing=999.) do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j G%geoLonT(i,j) = tmpZ(i2-1,j2-1) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index e818c33acd..1a40cdadc8 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -525,25 +525,71 @@ subroutine initialize_grid_rotation_angle(G, PF) !! to parse for model parameter values. real :: angle, lon_scale - integer :: i, j + real :: len_lon ! The periodic range of longitudes, usually 360 degrees. + real :: pi_720deg ! One quarter the conversion factor from degrees to radians. + real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value. + character(len=40) :: mdl = "initialize_grid_rotation_angle" ! This subroutine's name. + logical :: use_bugs + integer :: i, j, m, n + + call get_param(PF, mdl, "GRID_ROTATION_ANGLE_BUGS", use_bugs, & + "If true, use an older algorithm to calculate the sine and \n"//& + "cosines needed rotate between grid-oriented directions and \n"//& + "true north and east. Differences arise at the tripolar fold.", & + default=.True.) + + if (use_bugs) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon_scale = cos((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J-1 ) + & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J)) * atan(1.0)/180) + angle = atan2((G%geoLonBu(I-1,J) + G%geoLonBu(I,J) - & + G%geoLonBu(I-1,J-1) - G%geoLonBu(I,J-1))*lon_scale, & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J) - & + G%geoLatBu(I-1,J-1) - G%geoLatBu(I,J-1) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo - do j=G%jsc,G%jec ; do i=G%isc,G%iec - lon_scale = cos((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J-1 ) + & - G%geoLatBu(I-1,J) + G%geoLatBu(I,J)) * atan(1.0)/180) - angle = atan2((G%geoLonBu(I-1,J) + G%geoLonBu(I,J) - & - G%geoLonBu(I-1,J-1) - G%geoLonBu(I,J-1))*lon_scale, & - G%geoLatBu(I-1,J) + G%geoLatBu(I,J) - & - G%geoLatBu(I-1,J-1) - G%geoLatBu(I,J-1) ) - G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean - G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) - enddo ; enddo + ! This is not right at a tripolar or cubed-sphere fold. + call pass_var(G%cos_rot, G%Domain) + call pass_var(G%sin_rot, G%Domain) + else + pi_720deg = atan(1.0) / 180.0 + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do n=1,2 ; do m=1,2 + lonB(m,n) = modulo_around_point(G%geoLonBu(I+m-2,J+n-2), G%geoLonT(i,j), len_lon) + enddo ; enddo + lon_scale = cos(pi_720deg*((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J)) + & + (G%geoLatBu(I,J-1) + G%geoLatBu(I-1,J)) ) ) + angle = atan2(lon_scale*((lonB(1,2) - lonB(2,1)) + (lonB(2,2) - lonB(1,1))), & + (G%geoLatBu(I-1,J) - G%geoLatBu(I,J-1)) + & + (G%geoLatBu(I,J) - G%geoLatBu(I-1,J-1)) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo - ! ### THIS DOESN'T SEEM RIGHT AT A CUBED-SPHERE FOLD -RWH - call pass_var(G%cos_rot, G%Domain) - call pass_var(G%sin_rot, G%Domain) + call pass_vector(G%cos_rot, G%sin_rot, G%Domain, stagger=AGRID) + endif end subroutine initialize_grid_rotation_angle +! ----------------------------------------------------------------------------- +!> Return the modulo value of x in an interval [xc-(Lx/2) xc+(Lx/2)] +!! If Lx<=0, then it returns x without applying modulo arithmetic. +function modulo_around_point(x, xc, Lx) result(x_mod) + real, intent(in) :: x !< Value to which to apply modulo arithmetic + real, intent(in) :: xc !< Center of modulo range + real, intent(in) :: Lx !< Modulo range width + real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc. + + if (Lx > 0.0) then + x_mod = modulo(x - (xc - 0.5*Lx), Lx) + (xc - 0.5*Lx) + else + x_mod = x + endif +end function modulo_around_point + ! ----------------------------------------------------------------------------- !> This subroutine sets the open face lengths at selected points to restrict !! passages to their observed widths based on a named set of sizes. @@ -762,6 +808,8 @@ subroutine reset_face_lengths_list(G, param_file) real, pointer, dimension(:) :: & u_width => NULL(), v_width => NULL() real :: lat, lon ! The latitude and longitude of a point. + real :: len_lon ! The periodic range of longitudes, usually 360 degrees. + real :: len_lat ! The range of latitudes, usually 180 degrees. real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees. logical :: check_360 ! If true, check for longitudes that are shifted by ! +/- 360 degrees from the specified range of values. @@ -808,6 +856,8 @@ subroutine reset_face_lengths_list(G, param_file) call read_face_length_list(iounit, filename, num_lines, lines) endif + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + len_lat = 180.0 ; if (G%len_lat > 0.0) len_lat = G%len_lat ! Broadcast the number of lines and allocate the required space. call broadcast(num_lines, root_PE()) u_pt = 0 ; v_pt = 0 @@ -849,11 +899,11 @@ subroutine reset_face_lengths_list(G, param_file) read(line(isu+8:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt) if (is_root_PE()) then if (check_360) then - if ((abs(u_lon(1,u_pt)) > 360.0) .or. (abs(u_lon(2,u_pt)) > 360.0)) & + if ((abs(u_lon(1,u_pt)) > len_lon) .or. (abs(u_lon(2,u_pt)) > len_lon)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "u-longitude found when reading line "//trim(line)//" from file "//& trim(filename)) - if ((abs(u_lat(1,u_pt)) > 180.0) .or. (abs(u_lat(2,u_pt)) > 180.0)) & + if ((abs(u_lat(1,u_pt)) > len_lat) .or. (abs(u_lat(2,u_pt)) > len_lat)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "u-latitude found when reading line "//trim(line)//" from file "//& trim(filename)) @@ -876,11 +926,11 @@ subroutine reset_face_lengths_list(G, param_file) read(line(isv+8:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt) if (is_root_PE()) then if (check_360) then - if ((abs(v_lon(1,v_pt)) > 360.0) .or. (abs(v_lon(2,v_pt)) > 360.0)) & + if ((abs(v_lon(1,v_pt)) > len_lon) .or. (abs(v_lon(2,v_pt)) > len_lon)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "v-longitude found when reading line "//trim(line)//" from file "//& trim(filename)) - if ((abs(v_lat(1,v_pt)) > 180.0) .or. (abs(v_lat(2,v_pt)) > 180.0)) & + if ((abs(v_lat(1,v_pt)) > len_lat) .or. (abs(v_lat(2,v_pt)) > len_lat)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "v-latitude found when reading line "//trim(line)//" from file "//& trim(filename)) @@ -906,7 +956,7 @@ subroutine reset_face_lengths_list(G, param_file) do j=jsd,jed ; do I=IsdB,IedB lat = G%geoLatCu(I,j) ; lon = G%geoLonCu(I,j) - if (check_360) then ; lon_p = lon+360.0 ; lon_m = lon-360.0 + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon else ; lon_p = lon ; lon_m = lon ; endif do npt=1,u_pt @@ -936,7 +986,7 @@ subroutine reset_face_lengths_list(G, param_file) do J=JsdB,JedB ; do i=isd,ied lat = G%geoLatCv(i,J) ; lon = G%geoLonCv(i,J) - if (check_360) then ; lon_p = lon+360.0 ; lon_m = lon-360.0 + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon else ; lon_p = lon ; lon_m = lon ; endif do npt=1,v_pt diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index f662eda365..5fa4125fcb 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -77,7 +77,7 @@ module MOM_diabatic_aux !! This subroutine warms any water that is colder than the (currently !! surface) freezing point up to the freezing point and accumulates !! the required heat (in J m-2) in tv%frazil. -subroutine make_frazil(h, tv, G, GV, CS, p_surf) +subroutine make_frazil(h, tv, G, GV, CS, p_surf, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -88,6 +88,7 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) !! call to diabatic_aux_init. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: p_surf !< The pressure at the ocean surface, in Pa. + integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil ! Frazil formation keeps the temperature above the freezing point. ! This subroutine warms any water that is colder than the (currently @@ -113,7 +114,11 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif call cpu_clock_begin(id_clock_frazil) @@ -309,7 +314,7 @@ end subroutine differential_diffuse_T_S !> This subroutine keeps salinity from falling below a small but positive threshold. !! This usually occurs when the ice model attempts to extract more salt then !! is actually available to it from the ocean. -subroutine adjust_salt(h, tv, G, GV, CS) +subroutine adjust_salt(h, tv, G, GV, CS, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -318,6 +323,7 @@ subroutine adjust_salt(h, tv, G, GV, CS) !! available thermodynamic fields. type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init. + integer, optional, intent(in) :: halo !< Halo width over which to work ! local variables real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement @@ -325,6 +331,9 @@ subroutine adjust_salt(h, tv, G, GV, CS) real :: mc !< A layer's mass kg m-2 . integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif ! call cpu_clock_begin(id_clock_adjust_salt) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index e3806fd684..5985c6f054 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -154,7 +154,8 @@ module MOM_diabatic_driver !! fluxes are applied, in m. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be !! evaporated in one time-step (non-dim). - + integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that + !! must be valid for the diffusivity calculations. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport logical :: salt_reject_below_ML !< If true, add salt below mixed layer (layer mode only) logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. @@ -379,7 +380,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo integer :: ig, jg ! global indices for testing testing itide point source (BDM) logical :: avg_enabled ! for testing internal tides (BDM) @@ -447,9 +448,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) endif if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") @@ -465,15 +466,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) - do k=1,nz ; do j=js,je ; do i=is,ie + halo = CS%halo_TS_diff + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 enddo ; enddo ; enddo endif if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) @@ -1258,7 +1260,7 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo integer :: ig, jg ! global indices for testing testing itide point source (BDM) logical :: avg_enabled ! for testing internal tides (BDM) @@ -1323,9 +1325,9 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en endif if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) endif if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") @@ -1340,15 +1342,16 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) - do k=1,nz ; do j=js,je ; do i=is,ie + halo = CS%halo_TS_diff + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 enddo ; enddo ; enddo endif if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) @@ -1478,6 +1481,11 @@ subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_en ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S ! Also changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ???? ! And sets visc%Kv_shear + if ((CS%halo_TS_diff > 0) .and. (CS%ML_mix_first > 0.0)) then + if (associated(tv%T)) call pass_var(tv%T, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) + endif call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, CS%set_diff_CSp, Kd, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -3277,7 +3285,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! initialize module for setting diffusivities call set_diffusivity_init(Time, G, GV, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, & - CS%int_tide_CSp, CS%tidal_mixing_CSp) + CS%int_tide_CSp, CS%tidal_mixing_CSp, CS%halo_TS_diff) ! set up the clocks for this module diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 360c3a791d..b1fc1fd177 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -5,6 +5,7 @@ module MOM_geothermal use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl +use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_io, only : MOM_read_data, slasher @@ -44,7 +45,7 @@ module MOM_geothermal !! the partial derivative of the coordinate density with temperature is positive !! or very small, the layers are simply heated in place. Any heat that can not !! be applied to the ocean is returned (WHERE)? -subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) +subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. @@ -69,6 +70,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) type(geothermal_CS), pointer :: CS !< The control structure returned by !! a previous call to !! geothermal_init. + integer, optional, intent(in) :: halo !< Halo width over which to work ! Local variables real, dimension(SZI_(G)) :: & heat_rem, & ! remaining heat (H * degC) @@ -105,6 +107,9 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif if (.not. associated(CS)) call MOM_error(FATAL, "MOM_geothermal: "//& "Module must be initialized before it is used.") @@ -377,6 +382,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) CS%geo_heat(i,j) = G%mask2dT(i,j) * scale enddo ; enddo endif + call pass_var(CS%geo_heat, G%domain) ! post the static geothermal heating field id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 8d3206303c..7ef7f972ec 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -354,7 +354,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear",G%HI) - call Bchksum(visc%Kv_shear, "after calc_KS_vert visc%Kv_shear_Bu",G%HI) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu",G%HI) call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb",G%HI) endif else @@ -1892,7 +1892,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, CS, j, ds_dsp1, rho_0) end subroutine set_density_ratios subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp, int_tide_CSp, & - tm_CSp) + tm_CSp, halo_TS) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1907,6 +1907,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp !! structure (BDM) type(tidal_mixing_cs), pointer :: tm_csp !< pointer to tidal mixing control !! structure + integer, optional, intent(out) :: halo_TS !< The halo size of tracer points that must be + !! valid for the calculations in set_diffusivity. ! local variables real :: decay_length @@ -2228,6 +2230,11 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp if (CS%use_CVMix_ddiff) & id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) + if (present(halo_TS)) then + halo_TS = 0 + if (CS%Vertex_Shear) halo_TS = 1 + endif + end subroutine set_diffusivity_init !> Clear pointers and dealocate memory