diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index 21c82223ed..6422c69d33 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -620,13 +620,12 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse integer :: is_coarse, ie_coarse, js_coarse, je_coarse integer :: is_coarse2, ie_coarse2, js_coarse2, je_coarse2 - integer :: rotate - integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2) + integer :: is_convert2, ie_convert2, js_convert2, je_convert2, rotate2 integer :: isc_fine, iec_fine, jsc_fine, jec_fine integer :: isd_fine, ied_fine, jsd_fine, jed_fine integer :: x_refine, y_refine, ishift, jshift - integer :: nsend, nrecv, dir, l, nn - integer :: nconvert + integer :: nsend, nrecv, dir, nn + logical :: consider_pe integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:) integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:) integer, allocatable :: isgl_fine(:), iegl_fine(:), jsgl_fine(:), jegl_fine(:) @@ -793,14 +792,14 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi select case (m) case (1) !--- east halo receiving dir = 1 - is_coarse = overlap%east%is_you - ie_coarse = overlap%east%ie_you + is_coarse = overlap%east%is_you + ishift + ie_coarse = overlap%east%ie_you + ishift js_coarse = overlap%east%js_you - je_coarse = overlap%east%je_you + je_coarse = overlap%east%je_you + jshift case (2) !--- south halo receiving dir = 3 is_coarse = overlap%south%is_you - ie_coarse = overlap%south%ie_you + ie_coarse = overlap%south%ie_you + ishift js_coarse = overlap%south%js_you je_coarse = overlap%south%je_you case (3) !--- west halo receiving @@ -808,51 +807,35 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi is_coarse = overlap%west%is_you ie_coarse = overlap%west%ie_you js_coarse = overlap%west%js_you - je_coarse = overlap%west%je_you + je_coarse = overlap%west%je_you + jshift case (4) !--- north halo receiving dir = 7 is_coarse = overlap%north%is_you - ie_coarse = overlap%north%ie_you - js_coarse = overlap%north%js_you - je_coarse = overlap%north%je_you + ie_coarse = overlap%north%ie_you + ishift + js_coarse = overlap%north%js_you + jshift + je_coarse = overlap%north%je_you + jshift end select if( je_coarse .GE. js_coarse .AND. ie_coarse .GE. is_coarse ) then ! convert coarse grid index to the nested grid coarse grid index. - nconvert = convert_index_to_nest(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, & - jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%list(n-1)%tile_id(1), & - isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), & + consider_pe = convert_index(domain_coarse, domain_coarse%list(n-1)%tile_id(1), tile_coarse, & + domain_coarse%ntiles, isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), & is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is_coarse2 = max( is_coarse, is_convert2(l) ) - ie_coarse2 = min( ie_coarse, ie_convert2(l) ) - js_coarse2 = max( js_coarse, js_convert2(l) ) - je_coarse2 = min( je_coarse, je_convert2(l) ) - if( ie_coarse2 .GE. is_coarse2 .AND. je_coarse2 .GE. js_coarse2 ) then - select case (m) - case (1) !--- east halo - is_coarse2 = is_coarse2+ishift - ie_coarse2 = ie_coarse2+ishift - if(je_coarse2 == overlap%east%je_you) je_coarse2 = je_coarse2+jshift - case (2) !--- south halo - if(ie_coarse2 == overlap%south%ie_you) ie_coarse2 = ie_coarse2+ishift - case (3) !--- west halo - if(je_coarse2 == overlap%west%je_you) je_coarse2 = je_coarse2+jshift - case (4) !--- north halo - if(ie_coarse2 == overlap%north%ie_you) ie_coarse2 = ie_coarse2+ishift - js_coarse2 = js_coarse2+jshift - je_coarse2 = je_coarse2+jshift - end select + if (consider_pe) then + is_coarse2 = max( is_coarse, is_convert2 ) + ie_coarse2 = min( ie_coarse, ie_convert2 ) + js_coarse2 = max( js_coarse, js_convert2 ) + je_coarse2 = min( je_coarse, je_convert2 ) + if( ie_coarse2 .GE. is_coarse2 .AND. je_coarse2 .GE. js_coarse2 ) then if(is_first) then nrecv = nrecv + 1 call allocate_nest_overlap(overLaplist(nrecv), MAXOVERLAP) is_first = .false. endif - rotate = -rotate2(l) call insert_nest_overlap(overLaplist(nrecv), nest_domain%pelist_coarse(n), & - is_coarse2, ie_coarse2, js_coarse2, je_coarse2 , dir, rotate2(l)) + is_coarse2, ie_coarse2, js_coarse2, je_coarse2 , dir, rotate2) endif - enddo + endif endif enddo enddo @@ -882,40 +865,31 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi je_coarse = jstart_coarse + ( jel_fine(n) - jsg_fine )/y_refine js_coarse = js_coarse - shalo je_coarse = je_coarse + nhalo + + is_coarse = is_coarse + ishift + ie_coarse = ie_coarse + ishift + je_coarse = je_coarse + jshift + !--- convert the index to coarse grid index. - nconvert = convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, & - & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, ie_coarse,& - & js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is_coarse = max(isc_coarse, is_convert2(l)) - ie_coarse = min(iec_coarse, ie_convert2(l)) - js_coarse = max(jsc_coarse, js_convert2(l)) - je_coarse = min(jec_coarse, je_convert2(l)) + consider_pe = convert_index(domain_coarse, tile_coarse, domain_coarse%tile_id(1), & + domain_coarse%ntiles, is_coarse, ie_coarse, js_coarse, je_coarse, & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + if (consider_pe) then + is_coarse = max(isc_coarse, is_convert2) + ie_coarse = min(iec_coarse, ie_convert2) + js_coarse = max(jsc_coarse, js_convert2) + je_coarse = min(jec_coarse, je_convert2) if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then - if(rotate2(l)==ZERO) then - is_coarse = is_coarse+ishift - ie_coarse = ie_coarse+ishift - if( je_coarse == je_convert2(l) ) je_coarse = je_coarse+jshift - else if(rotate2(l) == MINUS_NINETY) then - js_coarse = js_coarse+ishift - je_coarse = je_coarse+ishift - if(is_coarse==is_convert2(l)) is_coarse = is_coarse-jshift - is_coarse = is_coarse+jshift - ie_coarse = ie_coarse+jshift - else if(rotate2(l) == NINETY) then - if(ie_coarse==ie_convert2(l)) ie_coarse = ie_coarse+jshift - endif - if(is_first) then nsend = nsend + 1 call allocate_nest_overlap(overLaplist(nsend), MAXOVERLAP) is_first = .false. endif - rotate = -rotate2(l) call insert_nest_overlap(overLaplist(nsend), nest_domain%pelist_fine(n), & - is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate) + is_coarse, ie_coarse, js_coarse, je_coarse , dir, -rotate2) endif - enddo + endif endif !--- to_pe's south @@ -923,36 +897,34 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi dir = 3 is_coarse = istart_coarse + ( isl_fine(n) - isg_fine )/x_refine ie_coarse = istart_coarse + ( iel_fine(n) - isg_fine )/x_refine - is_coarse = is_coarse - shalo - ie_coarse = ie_coarse + nhalo + is_coarse = is_coarse - whalo + ie_coarse = ie_coarse + ehalo js_coarse = jstart_coarse - shalo je_coarse = jstart_coarse + + ie_coarse = ie_coarse + ishift + !--- convert the index to coarse grid index. - nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, & - & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, & - & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is_coarse = max(isc_coarse, is_convert2(l)) - ie_coarse = min(iec_coarse, ie_convert2(l)) - js_coarse = max(jsc_coarse, js_convert2(l)) - je_coarse = min(jec_coarse, je_convert2(l)) + consider_pe = convert_index(domain_coarse, tile_coarse, domain_coarse%tile_id(1), & + domain_coarse%ntiles, is_coarse, ie_coarse, js_coarse, je_coarse, & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + if (consider_pe) then + is_coarse = max(isc_coarse, is_convert2) + ie_coarse = min(iec_coarse, ie_convert2) + js_coarse = max(jsc_coarse, js_convert2) + je_coarse = min(jec_coarse, je_convert2) if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then - if(rotate2(l)==ZERO .AND. ie_coarse==ie_convert2(l)) then - ie_coarse = ie_coarse+ishift - else if( rotate2(l) .NE. ZERO .AND. je_coarse == je_convert2(l) ) then - je_coarse = je_coarse+ishift - endif if(is_first) then nsend = nsend + 1 call allocate_nest_overlap(overLaplist(nsend), MAXOVERLAP) is_first = .false. endif - rotate = -rotate2(l) call insert_nest_overlap(overLaplist(nsend), nest_domain%pelist_fine(n), & - is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate) + is_coarse, ie_coarse, js_coarse, je_coarse , dir, -rotate2) endif - enddo + endif endif !--- to_pe's west @@ -964,31 +936,29 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi je_coarse = jstart_coarse + ( jel_fine(n) - jsg_fine )/y_refine js_coarse = js_coarse - shalo je_coarse = je_coarse + nhalo + + je_coarse = je_coarse + jshift + !--- convert the index to coarse grid index. - nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, & - & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, & - & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is_coarse = max(isc_coarse, is_convert2(l)) - ie_coarse = min(iec_coarse, ie_convert2(l)) - js_coarse = max(jsc_coarse, js_convert2(l)) - je_coarse = min(jec_coarse, je_convert2(l)) + consider_pe = convert_index(domain_coarse, tile_coarse, domain_coarse%tile_id(1), & + domain_coarse%ntiles, is_coarse, ie_coarse, js_coarse, je_coarse, & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + if (consider_pe) then + is_coarse = max(isc_coarse, is_convert2) + ie_coarse = min(iec_coarse, ie_convert2) + js_coarse = max(jsc_coarse, js_convert2) + je_coarse = min(jec_coarse, je_convert2) if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then - if(rotate2(l)==ZERO .and. je_coarse == je_convert2(l) ) then - je_coarse = je_coarse+jshift - else if(rotate2(l) .NE. ZERO .and. ie_coarse == ie_convert2(l) ) then - ie_coarse = ie_coarse+jshift - endif if(is_first) then nsend = nsend + 1 call allocate_nest_overlap(overLaplist(nsend), MAXOVERLAP) is_first = .false. endif - rotate = -rotate2(l) call insert_nest_overlap(overLaplist(nsend), nest_domain%pelist_fine(n), & - is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate) + is_coarse, ie_coarse, js_coarse, je_coarse , dir, -rotate2) endif - enddo + endif endif !--- to_pe's north @@ -996,43 +966,35 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi dir = 7 is_coarse = istart_coarse + ( isl_fine(n) - isg_fine )/x_refine ie_coarse = istart_coarse + ( iel_fine(n) - isg_fine )/x_refine - is_coarse = is_coarse - shalo - ie_coarse = ie_coarse + nhalo + is_coarse = is_coarse - whalo + ie_coarse = ie_coarse + ehalo js_coarse = jend_coarse je_coarse = jend_coarse + nhalo + + ie_coarse = ie_coarse + ishift + js_coarse = js_coarse + jshift + je_coarse = je_coarse + jshift + !--- convert the index to coarse grid index. - nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, & - & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, & - & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is_coarse = max(isc_coarse, is_convert2(l)) - ie_coarse = min(iec_coarse, ie_convert2(l)) - js_coarse = max(jsc_coarse, js_convert2(l)) - je_coarse = min(jec_coarse, je_convert2(l)) + consider_pe = convert_index(domain_coarse, tile_coarse, domain_coarse%tile_id(1), & + domain_coarse%ntiles, is_coarse, ie_coarse, js_coarse, je_coarse, & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + if (consider_pe) then + is_coarse = max(isc_coarse, is_convert2) + ie_coarse = min(iec_coarse, ie_convert2) + js_coarse = max(jsc_coarse, js_convert2) + je_coarse = min(jec_coarse, je_convert2) if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then - if(rotate2(l)==ZERO) then - if(ie_coarse==ie_convert2(l)) ie_coarse = ie_coarse+ishift - js_coarse = js_coarse+jshift - je_coarse = je_coarse+jshift - else if(rotate2(l) == NINETY) then - if(js_coarse==js_convert2(l)) js_coarse = js_coarse-ishift - js_coarse = js_coarse+ishift - je_coarse = je_coarse+ishift - is_coarse = is_coarse+jshift - ie_coarse = ie_coarse+jshift - else if(rotate2(l) == MINUS_NINETY ) then - if(je_coarse==je_convert2(l)) je_coarse = je_coarse+ishift - endif if(is_first) then nsend = nsend + 1 call allocate_nest_overlap(overLaplist(nsend), MAXOVERLAP) is_first = .false. endif - rotate = -rotate2(l) call insert_nest_overlap(overLaplist(nsend), nest_domain%pelist_fine(n), & - is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate) + is_coarse, ie_coarse, js_coarse, je_coarse , dir, -rotate2) endif - enddo + endif endif enddo endif @@ -1130,10 +1092,11 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) integer :: nsend, nrecv, dir integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:) integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:) - integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2) - integer :: is2, ie2, js2, je2, nconvert + integer :: is_convert2, ie_convert2, js_convert2, je_convert2, rotate2 + integer :: is2, ie2, js2, je2 + logical :: consider_pe integer :: xbegin_c, xend_c, ybegin_c, yend_c - integer :: ishift, jshift, l, is3, ie3, js3, je3, nn + integer :: ishift, jshift, is3, ie3, js3, je3, nn domain_fine => nest_domain%domain_fine domain_coarse => nest_domain%domain_coarse @@ -1239,33 +1202,41 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) ! the internal of fine grid to coarse grid. !----------------------------------------------------------------------------------------- do n = 1, npes_coarse - nconvert = convert_index_to_nest(domain_coarse, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, & - jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%list(n-1)%tile_id(1), & - isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), & - is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + consider_pe = convert_index(domain_coarse, domain_coarse%list(n-1)%tile_id(1), tile_coarse, & + domain_coarse%ntiles, isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + if (rotate2.eq.ZERO) then + ie_convert2 = ie_convert2 + ishift + je_convert2 = je_convert2 + jshift + else + ie_convert2 = ie_convert2 + jshift + je_convert2 = je_convert2 + ishift + endif + is2 = xbegin_c; ie2 = xend_c js2 = ybegin_c; je2 = yend_c is3 = is2; js3 = js2 - do l = 1, nconvert - if(rotate2(l) == NINETY .OR. rotate2(l) == MINUS_NINETY) then + if (consider_pe) then + if(rotate2 == NINETY .OR. rotate2 == MINUS_NINETY) then ie3 = ie2 + jshift je3 = je2 + ishift else ie3 = ie2 + ishift je3 = je2 + jshift endif - is_coarse = max( is3, is_convert2(l) ) - ie_coarse = min( ie3, ie_convert2(l) ) - js_coarse = max( js3, js_convert2(l) ) - je_coarse = min( je3, je_convert2(l) ) + is_coarse = max( is3, is_convert2 ) + ie_coarse = min( ie3, ie_convert2 ) + js_coarse = max( js3, js_convert2 ) + je_coarse = min( je3, je_convert2 ) if(ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then dir = 0 nsend = nsend + 1 call allocate_nest_overlap(overLaplist(nsend), MAXOVERLAP) call insert_nest_overlap(overLaplist(nsend), nest_domain%pelist_coarse(n), & - is_coarse, ie_coarse, js_coarse, je_coarse, dir, rotate2(l)) + is_coarse, ie_coarse, js_coarse, je_coarse, dir, -rotate2) endif - enddo + endif enddo enddo overlap%nsend = nsend @@ -1311,22 +1282,26 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) js_you = jstart_coarse + (jsl_fine(n)-jstart_fine)/y_refine je_you = jstart_coarse + (jel_fine(n)-jstart_fine)/y_refine if(mod(jsl_fine(n)-jstart_fine, y_refine) .NE. 0 ) js_you = js_you + 1 - nconvert=convert_index_to_coarse(domain_coarse, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, & - & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_you, ie_you, & - & js_you, je_you, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) - do l = 1, nconvert - is2 = max(is_convert2(l), isc_coarse) - ie2 = min(ie_convert2(l), iec_coarse+ishift) - js2 = max(js_convert2(l), jsc_coarse) - je2 = min(je_convert2(l), jec_coarse+jshift) + consider_pe = convert_index(domain_coarse, tile_coarse, domain_coarse%tile_id(1), & + domain_coarse%ntiles, is_you, ie_you, js_you, je_you, & + is_convert2, ie_convert2, js_convert2, je_convert2, rotate2) + + ie_convert2 = ie_convert2 + ishift + je_convert2 = je_convert2 + jshift + + if (consider_pe) then + is2 = max(is_convert2, isc_coarse) + ie2 = min(ie_convert2, iec_coarse+ishift) + js2 = max(js_convert2, jsc_coarse) + je2 = min(je_convert2, jec_coarse+jshift) if( ie2 .GE. is2 .AND. je2 .GE. js2 ) then nrecv = nrecv + 1 call allocate_nest_overlap(overLaplist(nrecv), MAXOVERLAP) call insert_nest_overlap(overLaplist(nrecv), nest_domain%pelist_fine(n), & - is2, ie2, js2, je2, dir, rotate2(l)) + is2, ie2, js2, je2, dir, rotate2) endif - enddo + endif enddo enddo overlap%nrecv = nrecv @@ -1933,344 +1908,121 @@ function search_C2F_nest_overlap(nest_domain, nest_level, extra_halo, position) end subroutine get_nnest - !> This routine will convert the global coarse grid index to nest grid index. - function convert_index_to_nest(domain, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, & - & jend_coarse, ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in, is_out, ie_out,& - & js_out, je_out, rotate_out) - type(domain2D), intent(in) :: domain - integer, intent(in) :: ishift, jshift - integer, intent(in) :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse - integer, intent(in) :: tile_coarse - integer, intent(in) :: ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in - integer, intent(out) :: is_out(:), ie_out(:), js_out(:), je_out(:), rotate_out(:) - integer :: convert_index_to_nest - integer :: is, ie, js, je, tile, isg, ieg, jsg, jeg - integer :: ncross, rotate, nout, diff, ntiles - - ntiles = ntiles_coarse - call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - is = istart_coarse; ie = iend_coarse - js = jstart_coarse; je = jend_coarse - tile = tile_coarse - - if(size(is_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_nest: size(is_out(:)) < 2") - if(size(ie_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_nest: size(ie_out(:)) < 2") - if(size(js_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_nest: size(js_out(:)) < 2") - if(size(je_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_nest: size(je_out(:)) < 2") - if(size(rotate_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_nest: size(rotate_out(:)) < 2") - if( ie > ieg .AND. je > jeg) then - call mpp_error(FATAL, "convert_index_to_nest: do not support cross the corner, contact developer") - endif - if( is > ieg .or. js > jeg) call mpp_error(FATAL,"convert_index_to_nest: is > ieg .or. js > jeg") +!> @brief Transform the coordinates defining a region from one tile to another +!! +!! Given the coordinates defining a region on `tile_from`, transform those indices +!! into the coordinate system of `tile_to`. Only adjacent tiles are supported. +!! +!! @return .true. if `tile_from` and `tile_to` are equal or adjacent; otherwise, .false. + function convert_index(domain, tile_from, tile_to, ntiles, is_in, ie_in, js_in, je_in, & + is_out, ie_out, js_out, je_out, rot) result(consider_pe) + type(domain2D), intent(in) :: domain !< Coarse grid's domain + integer, intent(in) :: tile_from, tile_to !< Source and destination tiles for the coordinate transform + integer, intent(in) :: ntiles !< Number of tiles on the coarse grid + integer, intent(in) :: is_in, ie_in, js_in, je_in !< Indices defining a region on tile_from + integer, intent(out) :: is_out, ie_out, js_out, je_out !< Corresponding indices in tile_to's coordinate system + integer, intent(out) :: rot !< Angle by which vectors on `tile_from` must be rotated + logical :: consider_pe !< This is true if tile_from and tile_to are adjacent, and false otherwise. + integer :: isg, ieg, jsg, jeg + integer :: delta, nx, ny, icross, jcross + logical :: is_even + consider_pe = .true. - nout = 0 + call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - if(tile == tile_in) then - nout = nout+1 - rotate_out(nout) = ZERO - is_out(nout) = is_in; ie_out(nout) = ie_in + ishift - js_out(nout) = js_in; je_out(nout) = je_in + jshift + delta = tile_from - tile_to + if (abs(delta).eq.3) then + consider_pe = .false. + return endif - diff = tile_in - tile - if(diff < 0) diff = diff + ntiles - ncross = -1 - if( ie > ieg ) then - select case(diff) - case (0) - rotate = ZERO - ncross = 4 - case (1) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = ZERO - ncross = 1 - endif - case (2) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = MINUS_NINETY - ncross = 1 - endif - case (3) - rotate = MINUS_NINETY - ncross = 2 - case (4) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = MINUS_NINETY - ncross = 3 - endif - case (5) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = ZERO - ncross = 3 - endif - case default - call mpp_error(FATAL,"convert_index_to_nest: invalid value of diff") - end select - - if(ncross > 0) then - nout =nout+1 - rotate_out(nout) = rotate - if(rotate_out(nout) == ZERO) then - js_out(nout) = js_in - je_out(nout) = je_in + jshift - is_out(nout) = is_in+ncross*ieg - ie_out(nout) = ie_in+ncross*ieg + ishift - else if(rotate_out(nout) == MINUS_NINETY) then - js_out(nout) = ieg-ie_in + 1 - je_out(nout) = ieg-is_in + 1 + ishift - is_out(nout) = js_in+ncross*jeg - ie_out(nout) = je_in+ncross*jeg + jshift - endif - endif - else if( je > jeg ) then - select case(diff) - case (0) - rotate = ZERO - ncross = 4 - case (1) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = ZERO - ncross = 1 - endif - case (2) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = NINETY - ncross = 1 - endif - case (3) - rotate = NINETY - ncross = 2 - case (4) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = NINETY - ncross = 3 - endif - case (5) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = ZERO - ncross = 3 - endif - end select - - if(ncross > 0) then - nout =nout+1 - rotate_out(nout) = rotate - - if(rotate_out(nout) == ZERO) then - js_out(nout) = js_in - je_out(nout) = je_in + jshift - is_out(nout) = is_in+ncross*ieg - ie_out(nout) = ie_in+ncross*ieg + ishift - else if(rotate_out(nout) == NINETY) then - is_out(nout) = ieg-je_in + 1 - ie_out(nout) = ieg-js_in+1 + jshift - js_out(nout) = is_in+ncross*jeg - je_out(nout) = ie_in+ncross*jeg + ishift - endif - endif - endif + if (delta.gt.3) delta = delta - ntiles + if (delta.lt.-3) delta = delta + ntiles - convert_index_to_nest = nout + ! At this stage, delta should be in the range from -2 to +2. + ! - A value of +/- 1 corresponds to a simple translation. + ! - A value of +/- 2 corresponds to a rotation followed by a translation. + ! - A value of +/- 3 corresponds to a tile on the opposite face of the cubed sphere (ignored here). - end function convert_index_to_nest + is_even = mod(tile_to,2).eq.0 - function convert_index_to_coarse(domain, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, & - & jend_coarse, ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in, is_out, ie_out,& - & js_out, je_out, rotate_out) - type(domain2D), intent(in) :: domain - integer, intent(in) :: ishift, jshift - integer, intent(in) :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse - integer, intent(in) :: tile_coarse - integer, intent(in) :: ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in - integer, intent(out) :: is_out(:), ie_out(:), js_out(:), je_out(:), rotate_out(:) - integer :: convert_index_to_coarse - integer :: is, ie, js, je, isg, ieg, jsg, jeg - integer :: ncross, rotate, ntiles, nout, diff, tile - - ntiles = ntiles_coarse - call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - is = istart_coarse; ie = iend_coarse - js = jstart_coarse; je = jend_coarse - tile = tile_coarse - - if(size(is_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_coarse: size(is_out(:)) < 2") - if(size(ie_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_coarse: size(ie_out(:)) < 2") - if(size(js_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_coarse: size(js_out(:)) < 2") - if(size(je_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_coarse: size(je_out(:)) < 2") - if(size(rotate_out(:)) < 2) call mpp_error(FATAL,"convert_index_to_coarse: size(rotate_out(:)) < 2") - if( ie > ieg .AND. je > jeg) then - call mpp_error(FATAL, "convert_index_to_coarse: do not support cross the corner, contact developer") + rot = ZERO + if (is_even) then + select case (delta) + case (-2) + rot = MINUS_NINETY + case (2) + rot = NINETY + end select + else + select case (delta) + case (-2) + rot = NINETY + case (2) + rot = MINUS_NINETY + end select endif - if( is > ieg .or. js > jeg) call mpp_error(FATAL,"convert_index_to_coarse: is > ieg .or. js > jeg") - nout = 0 - - if(tile_coarse == tile_in) then - nout = nout+1 - rotate_out(nout) = ZERO - is_out(nout) = is_in; ie_out(nout) = ie_in + ishift - js_out(nout) = js_in; je_out(nout) = je_in + jshift - endif + select case (rot) + case (ZERO) + is_out = is_in + ie_out = ie_in + js_out = js_in + je_out = je_in + + case (NINETY) + is_out = js_in + ie_out = je_in + je_out = ieg - (is_in - isg) + js_out = ieg - (ie_in - isg) + case (MINUS_NINETY) + ie_out = jeg - (js_in - jsg) + is_out = jeg - (je_in - jsg) + js_out = is_in + je_out = ie_in + end select - diff = tile_in - tile - if(diff < 0) diff = diff + ntiles - ncross = -1 - if( ie > ieg ) then - select case(diff) - case (0) - rotate = ZERO - ncross = 4 - case (1) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = ZERO - ncross = 1 - endif - case (2) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = MINUS_NINETY - ncross = 1 - endif - case (3) - rotate = MINUS_NINETY - ncross = 2 - case (4) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = MINUS_NINETY - ncross = 3 - endif - case (5) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = ZERO - ncross = 3 - endif - case default - call mpp_error(FATAL,"convert_index_to_coarse: invalid value of diff") - end select - - if(ncross > 0) then - nout =nout+1 - rotate_out(nout) = rotate - if(rotate_out(nout) == ZERO) then - js_out(nout) = js_in - je_out(nout) = je_in + jshift - is_out(nout) = is_in-ncross*ieg - ie_out(nout) = ie_in-ncross*ieg + ishift - else if(rotate_out(nout) == MINUS_NINETY) then - is_out(nout) = ieg-je_in + 1 - ie_out(nout) = ieg-js_in + 1 + ishift - js_out(nout) = is_in-ncross*jeg - je_out(nout) = ie_in-ncross*jeg + jshift - endif - endif - else if( je > jeg ) then - select case(diff) - case (0) - rotate = ZERO - ncross = 4 - case (1) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = ZERO - ncross = 1 - endif - case (2) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = NINETY - ncross = 1 - endif - case (3) - rotate = NINETY - ncross = 2 - case (4) - if(mod(tile,2) ==0) then ! tile 2 4 6 - rotate = NINETY - ncross = 3 - endif - case (5) - if(mod(tile,2) ==1) then ! tile 1 3 5 - rotate = ZERO - ncross = 3 - endif - end select - - if(ncross > 0) then - nout =nout+1 - rotate_out(nout) = rotate - - if(rotate_out(nout) == ZERO) then - js_out(nout) = js_in - je_out(nout) = je_in + jshift - is_out(nout) = is_in-ncross*ieg - ie_out(nout) = ie_in-ncross*ieg + ishift - else if(rotate_out(nout) == NINETY) then - is_out(nout) = js_in - ncross*jeg - ie_out(nout) = je_in - ncross*jeg + ishift - js_out(nout) = jeg - ie_in + 1 - je_out(nout) = jeg - is_in + 1 + jshift - endif - endif + if (rot.eq.ZERO) then + nx = ieg - isg + 1 + ny = jeg - jsg + 1 + else + nx = jeg - jsg + 1 + ny = ieg - isg + 1 endif - convert_index_to_coarse = nout - - - end function convert_index_to_coarse - - - subroutine convert_index_back(domain, ishift, jshift, rotate, is_in, ie_in, js_in, je_in, is_out, ie_out, & - & js_out, je_out) - type(domain2D), intent(in) :: domain - integer, intent(in) :: ishift, jshift - integer, intent(in) :: is_in, ie_in, js_in, je_in, rotate - integer, intent(out) :: is_out, ie_out, js_out, je_out - integer :: isg, ieg, jsg, jeg - integer :: ncross - - call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) - ncross = 0 - if( je_in > jeg+jshift .and. ie_in > ieg+ishift ) then - call mpp_error(FATAL,"convert_index_back: je_in > jeg .and. ie_in > ieg") - else if (je_in > jeg+jshift) then - ncross = je_in/jeg - select case(rotate) - case(0) - is_out = is_in - ie_out = ie_in - js_out = js_in - ncross*jeg - je_out = je_in - ncross*jeg - case(90) - is_out = js_in - ncross*jeg - ie_out = je_in - ncross*jeg - js_out = jeg - ie_in + 1 - je_out = jeg - is_in + 1 - case default - call mpp_error(FATAL, "convert_index_back: rotate should be 0 or 90 when je_in>jeg") - end select - else if (ie_in > ieg+ishift) then - ncross = ie_in/ieg - select case(rotate) - case(0) - is_out = is_in - ncross*ieg - ie_out = ie_in - ncross*ieg - js_out = js_in - je_out = je_in - case(-90) - js_out = is_in - ncross*ieg - je_out = ie_in - ncross*ieg - is_out = ieg - je_in + 1 - ie_out = ieg - js_in + 1 - case default - call mpp_error(FATAL, "convert_index_back: rotate should be 0 or -90 when ie_in>ieg") - end select + icross = 0 + jcross = 0 + + if (is_even) then + select case (delta) + case (-2) + jcross = -1 + case (-1) + icross = -1 + case (1) + jcross = 1 + case (2) + icross = 1 + end select else - is_out = is_in - ie_out = ie_in - js_out = js_in - je_out = je_in + select case (delta) + case (-2) + icross = -1 + case (-1) + jcross = -1 + case (1) + icross = 1 + case (2) + jcross = 1 + end select endif - end subroutine convert_index_back - + is_out = is_out + icross*nx + ie_out = ie_out + icross*nx + js_out = js_out + jcross*ny + je_out = je_out + jcross*ny + end function convert_index function get_nest_vector_recv(nest_domain, update_x, update_y, ind_x, ind_y, start_pos, pelist) diff --git a/test_fms/mpp/test_mpp_nesting.sh b/test_fms/mpp/test_mpp_nesting.sh index 405c2c4bd4..97fa5224df 100755 --- a/test_fms/mpp/test_mpp_nesting.sh +++ b/test_fms/mpp/test_mpp_nesting.sh @@ -60,7 +60,7 @@ num_nest = 3 tile_coarse = 1, 3, 7 tile_fine = 7 , 8, 9 istart_coarse = 3, 3, 5 -icount_coarse = 40, 5, 6 +icount_coarse = 30, 5, 6 jstart_coarse = 3, 3, 6 jcount_coarse = 14, 6, 8 extra_halo = 0 @@ -88,7 +88,7 @@ test_expect_success "update nest domain" ' sed "s/tile_coarse = 1, 3, 7/tile_coarse = 1, 1, 2/" input_base.nml > input.nml sed -i "s/tile_fine = 7 , 8, 9/tile_fine = 2 , 3, 4/" input.nml sed -i "s/istart_coarse = 3, 3, 5/istart_coarse = 4, 3, 5/" input.nml -sed -i "s/icount_coarse = 40, 5, 6/icount_coarse = 12, 5, 6/" input.nml +sed -i "s/icount_coarse = 30, 5, 6/icount_coarse = 12, 5, 6/" input.nml sed -i "s/jstart_coarse = 3, 3, 6/jstart_coarse = 4, 3, 6/" input.nml sed -i "s/jcount_coarse = 14, 6, 8/jcount_coarse = 12, 6, 8/" input.nml sed -i "s/ntiles_nest_all = 9/ntiles_nest_all = 4/" input.nml