27 integer,
intent(in) :: global_indices(:)
28 integer,
intent(in) :: ndivs
29 integer,
intent(out) :: layout(:)
31 integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
33 if(
size(global_indices(:)) .NE. 4)
call mpp_error(fatal,
"mpp_define_layout2D: size of global_indices should be 4")
34 if(
size(layout(:)) .NE. 2)
call mpp_error(fatal,
"mpp_define_layout2D: size of layout should be 2")
36 isg = global_indices(1)
37 ieg = global_indices(2)
38 jsg = global_indices(3)
39 jeg = global_indices(4)
44 idiv = nint( sqrt(float(ndivs*isz)/jsz) )
46 do while( mod(ndivs,idiv).NE.0 )
51 layout = (/ idiv, jdiv /)
62 integer,
dimension(:),
intent(in) :: sizes
63 integer,
dimension(:),
intent(inout) :: pe_start, pe_end
64 integer,
dimension(:),
intent(in),
optional :: pelist, costpertile
65 integer,
dimension(size(sizes(:))) :: costs
66 integer,
dimension(:),
allocatable :: pes
67 integer :: ntiles, npes, totcosts, avgcost
68 integer :: ntiles_left, npes_left, pos, n, tile
69 integer :: cost_on_tile, cost_on_pe, npes_used, errunit
71 ntiles =
size(sizes(:))
72 if(
size(pe_start(:)) .NE. ntiles .OR.
size(pe_end(:)) .NE. ntiles )
then
73 call mpp_error(fatal,
"mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
76 if(
present(costpertile))
then
77 if(
size(costpertile(:)) .NE. ntiles )
then
78 call mpp_error(fatal,
"mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
80 costs = sizes*costpertile
85 if(
PRESENT(pelist) )
then
86 if( .NOT.any(pelist.EQ.
mpp_pe()) )
then
88 write( errunit,* )
'pe=',
mpp_pe(),
' pelist=', pelist
89 call mpp_error( fatal,
'mpp_define_mosaic_pelist: pe must be in pelist.' )
91 npes =
size(pelist(:))
92 allocate( pes(0:npes-1) )
96 allocate( pes(0:npes-1) )
97 call mpp_get_current_pelist(pes)
104 do while( ntiles_left > 0 )
105 if( npes_left == 1 )
then
107 if(costs(n) > 0)
then
116 totcosts = sum(costs)
117 avgcost = ceiling(real(totcosts)/npes_left )
118 tile = minval(maxloc(costs))
119 cost_on_tile = costs(tile)
121 ntiles_left = ntiles_left - 1
123 totcosts = totcosts - cost_on_tile
124 if(cost_on_tile .GE. avgcost )
then
125 npes_used = min(ceiling(real(cost_on_tile)/avgcost), npes_left)
126 if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
127 pe_end(tile) = pos + npes_used - 1
128 npes_left = npes_left - npes_used
129 pos = pos + npes_used
133 cost_on_pe = cost_on_tile
134 do while(ntiles_left>npes_left)
135 tile = minval(minloc(costs, costs> 0 ))
136 cost_on_tile = costs(tile)
137 cost_on_pe = cost_on_pe + cost_on_tile
138 if(cost_on_pe > avgcost )
exit
141 ntiles_left = ntiles_left - 1
143 totcosts = totcosts - cost_on_tile
145 npes_left = npes_left - 1
151 if(npes_left .NE. 0 )
call mpp_error(fatal,
"mpp_define_mosaic_pelist: the left npes should be zero")
161 integer,
intent(in) :: isg, ieg, ndivs
162 integer,
dimension(:),
intent(out) :: ibegin, iend
170 is = ie - ceiling( real(ie-isg+1)/ndiv ) + 1
174 if( ie.LT.is )
call mpp_error( fatal, &
175 'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
176 if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE. isg ) &
177 call mpp_error( fatal,
'mpp_compute_block_extent: domain extents do not span space completely.' )
187 integer,
intent(in) :: isg, ieg, ndivs
188 integer,
dimension(0:),
intent(out) :: ibegin, iend
189 integer,
dimension(0:),
intent(in),
optional :: extent
191 integer :: ndiv, imax, ndmax, ndmirror
193 logical :: symmetrize, use_extent
196 even(n) = (mod(n,2).EQ.0)
197 odd(n) = (mod(n,2).EQ.1)
200 if(
PRESENT(extent))
then
201 if(
size(extent(:)).NE.ndivs ) &
202 call mpp_error( fatal,
'mpp_compute_extent: extent array size must equal number of domain divisions.' )
204 if(all(extent ==0)) use_extent = .false.
211 if(extent(ndiv) .LE. 0)
call mpp_error( fatal, &
212 &
'mpp_compute_extent: domain extents must be positive definite.' )
213 iend(ndiv) = ibegin(ndiv) + extent(ndiv) - 1
214 ibegin(ndiv+1) = iend(ndiv) + 1
216 iend(ndivs-1) = ibegin(ndivs-1) + extent(ndivs-1) - 1
217 if(iend(ndivs-1) .NE. ieg)
call mpp_error(fatal, &
218 &
'mpp_compute_extent: extent array limits do not match global domain.' )
232 symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
233 ( odd(ndivs) .AND. odd(ieg-isg+1) ) .OR. &
234 ( odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
243 if( ndiv.LT.(ndivs-1)/2+1 )
then
245 ie = is + ceiling( real(imax-is+1)/(ndmax-ndiv) ) - 1
246 ndmirror = (ndivs-1) - ndiv
247 if( ndmirror.GT.ndiv .AND. symmetrize )
then
249 ibegin(ndmirror) = max( isg+ieg-ie, ie+1 )
250 iend(ndmirror) = max( isg+ieg-is, ie+1 )
251 imax = ibegin(ndmirror) - 1
260 ie = is + ceiling( real(imax-is+1)/(ndmax-ndiv) ) - 1
265 if( ie.LT.is )
call mpp_error( fatal, &
266 'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
267 if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.ieg ) &
268 call mpp_error( fatal,
'mpp_compute_extent: domain extents do not span space completely.' )
281 memory_size, begin_halo, end_halo )
282 integer,
intent(in) :: global_indices(:)
283 integer,
intent(in) :: ndivs
284 type(domain1d),
intent(inout) :: domain
286 integer,
intent(in),
optional :: pelist(0:)
289 integer,
intent(in),
optional :: flags, halo
293 integer,
intent(in),
optional :: extent(0:)
295 logical,
intent(in),
optional :: maskmap(0:)
300 integer,
intent(in),
optional :: memory_size
301 integer,
intent(in),
optional :: begin_halo, end_halo
303 logical :: compute_domain_is_global, data_domain_is_global
304 integer :: ndiv, n, isg, ieg
305 integer,
allocatable :: pes(:)
306 integer :: ibegin(0:ndivs-1), iend(0:ndivs-1)
307 logical :: mask(0:ndivs-1)
308 integer :: halosz, halobegin, haloend
311 if( .NOT.module_is_initialized )
call mpp_error( fatal, &
312 &
'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
313 if(
size(global_indices(:)) .NE. 2)
call mpp_error(fatal,
"mpp_define_domains1D: size of global_indices should be 2")
315 isg = global_indices(1)
316 ieg = global_indices(2)
317 if( ndivs.GT.ieg-isg+1 )
call mpp_error( fatal, &
318 &
'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
320 if(
PRESENT(pelist) )
then
321 if( .NOT.any(pelist.EQ.
mpp_pe()) )
then
323 write( errunit,* )
'pe=',
mpp_pe(),
' pelist=', pelist
324 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
326 allocate( pes(0:
size(pelist(:))-1) )
330 call mpp_get_current_pelist(pes)
336 if(
PRESENT(maskmap) )
then
337 if(
size(maskmap(:)).NE.ndivs ) &
338 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
341 if( count(mask).NE.
size(pes(:)) ) &
342 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
346 if(
PRESENT(halo) )
then
349 if(
present(begin_halo) .OR.
present(end_halo) )
call mpp_error(fatal, &
350 "mpp_domains_define.inc: when halo is present, begin_halo and end_halo should not present")
352 halobegin = halosz; haloend = halosz
353 if(
present(begin_halo)) halobegin = begin_halo
354 if(
present(end_halo)) haloend = end_halo
355 halosz = max(halobegin, haloend)
357 compute_domain_is_global = .false.
358 data_domain_is_global = .false.
359 domain%cyclic = .false.
362 if(
PRESENT(flags) )
then
365 compute_domain_is_global = ndivs.EQ.1
367 data_domain_is_global = btest(flags,global) .OR. compute_domain_is_global
368 domain%cyclic = btest(flags,cyclic) .AND. halosz.NE.0
369 if(btest(flags,cyclic)) domain%goffset = 0
373 allocate( domain%list(0:ndivs-1) )
376 domain%list(:)%global%begin = isg
377 domain%list(:)%global%end = ieg
378 domain%list(:)%global%size = ieg-isg+1
379 domain%list(:)%global%max_size = ieg-isg+1
380 domain%list(:)%global%is_global = .true.
383 if( compute_domain_is_global )
then
384 domain%list(:)%compute%begin = isg
385 domain%list(:)%compute%end = ieg
386 domain%list(:)%compute%is_global = .true.
387 domain%list(:)%pe = pes(:)
390 domain%list(:)%compute%is_global = .false.
394 domain%list(ndiv)%compute%begin = ibegin(ndiv)
395 domain%list(ndiv)%compute%end = iend(ndiv)
397 domain%list(ndiv)%pe = pes(n)
398 if(
mpp_pe().EQ.pes(n) )domain%pos = ndiv
401 domain%list(ndiv)%pe = null_pe
406 domain%list(:)%compute%size = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
410 domain%list(:)%domain_data%begin = domain%list(:)%compute%begin
411 domain%list(:)%domain_data%end = domain%list(:)%compute%end
412 domain%list(:)%domain_data%is_global = .false.
414 if( data_domain_is_global )
then
415 domain%list(:)%domain_data%begin = isg
416 domain%list(:)%domain_data%end = ieg
417 domain%list(:)%domain_data%is_global = .true.
420 domain%list(:)%domain_data%begin = domain%list(:)%domain_data%begin - halobegin
421 domain%list(:)%domain_data%end = domain%list(:)%domain_data%end + haloend
422 domain%list(:)%domain_data%size = domain%list(:)%domain_data%end - domain%list(:)%domain_data%begin + 1
427 domain%list(:)%memory%begin = domain%list(:)%domain_data%begin
428 domain%list(:)%memory%end = domain%list(:)%domain_data%end
429 if(
present(memory_size) )
then
430 if(memory_size > 0)
then
431 if( domain%list(domain%pos)%domain_data%size > memory_size )
call mpp_error(fatal, &
432 "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe")
433 domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1
436 domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1
437 domain%list(:)%memory%is_global = domain%list(:)%domain_data%is_global
439 domain%compute = domain%list(domain%pos)%compute
440 domain%domain_data = domain%list(domain%pos)%domain_data
441 domain%global = domain%list(domain%pos)%global
442 domain%memory = domain%list(domain%pos)%memory
443 domain%compute%max_size = maxval( domain%list(:)%compute%size )
444 domain%domain_data%max_size = maxval( domain%list(:)%domain_data%size )
445 domain%global%max_size = domain%global%size
446 domain%memory%max_size = domain%memory%size
457 type(domain2d),
intent(inout) :: domain
458 integer,
intent(in ) :: io_layout(2)
460 integer :: npes_in_group
461 type(domain2d),
pointer :: io_domain=>null()
462 integer :: i, j, n, m
463 integer :: ipos, jpos, igroup, jgroup
464 integer :: ipos_beg, ipos_end, jpos_beg, jpos_end
465 integer :: whalo, ehalo, shalo, nhalo
466 integer :: npes_x, npes_y, ndivx, ndivy
467 integer,
allocatable :: posarray(:,:)
469 if(io_layout(1) * io_layout(2) .LE. 0)
then
470 call mpp_error(note, &
471 "mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for "//trim(domain%name)// &
472 " when one or both entry of io_layout is not positive")
476 layout(1) =
size(domain%x(1)%list(:))
477 layout(2) =
size(domain%y(1)%list(:))
479 if(
ASSOCIATED(domain%io_domain))
call mpp_error(fatal, &
480 "mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
482 if(mod(layout(1), io_layout(1)) .NE. 0)
call mpp_error(fatal, &
483 "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
484 &
" domain layout(1) must be divided by io_layout(1)")
485 if(mod(layout(2), io_layout(2)) .NE. 0)
call mpp_error(fatal, &
486 "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
487 &
" domain layout(2) must be divided by io_layout(2)")
488 if(
size(domain%x(:)) > 1)
call mpp_error(fatal, &
489 "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
490 ": multiple tile per pe is not supported yet for this routine")
492 if (
associated(domain%io_domain))
deallocate(domain%io_domain)
493 allocate(domain%io_domain)
494 domain%io_layout = io_layout
495 io_domain => domain%io_domain
497 npes_x = layout(1)/io_layout(1)
498 npes_y = layout(2)/io_layout(2)
499 ipos = mod(domain%x(1)%pos, npes_x)
500 jpos = mod(domain%y(1)%pos, npes_y)
501 igroup = domain%x(1)%pos/npes_x
502 jgroup = domain%y(1)%pos/npes_y
503 ipos_beg = igroup*npes_x; ipos_end = ipos_beg + npes_x - 1
504 jpos_beg = jgroup*npes_y; jpos_end = jpos_beg + npes_y - 1
506 do j = jpos_beg, jpos_end
507 do i = ipos_beg, ipos_end
508 if(domain%pearray(i,j) .NE. null_pe) npes_in_group = npes_in_group+1
512 io_domain%whalo = domain%whalo
513 io_domain%ehalo = domain%ehalo
514 io_domain%shalo = domain%shalo
515 io_domain%nhalo = domain%nhalo
517 io_domain%pe = domain%pe
518 io_domain%symmetry = domain%symmetry
519 if (
associated(io_domain%list))
deallocate(io_domain%list)
520 allocate(io_domain%list(0:npes_in_group-1))
521 do i = 0, npes_in_group-1
522 allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) )
525 ndivx =
size(domain%pearray,1)
526 ndivy =
size(domain%pearray,2)
527 allocate(posarray(0:ndivx-1, 0:ndivy-1))
528 n = domain%tile_root_pe - mpp_root_pe()
532 if( domain%pearray(i,j) == null_pe) cycle
539 do j = jpos_beg, jpos_end
540 do i = ipos_beg, ipos_end
541 if( domain%pearray(i,j) == null_pe) cycle
542 io_domain%list(n)%pe = domain%pearray(i,j)
544 io_domain%list(n)%x(1)%compute = domain%list(m)%x(1)%compute
545 io_domain%list(n)%y(1)%compute = domain%list(m)%y(1)%compute
546 igroup = domain%list(m)%x(1)%pos/npes_x
547 jgroup = domain%list(m)%y(1)%pos/npes_y
548 io_domain%list(n)%tile_id(1) = jgroup*io_layout(1) + igroup
554 if (
associated(io_domain%x))
deallocate(io_domain%x)
555 if (
associated(io_domain%y))
deallocate(io_domain%y)
556 if (
associated(io_domain%tile_id))
deallocate(io_domain%tile_id)
557 allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
558 allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) )
560 do j = jpos_beg, jpos_beg+jpos
561 do i = ipos_beg, ipos_beg+ipos
562 if(domain%pearray(i,j) .NE. null_pe) n = n + 1
566 io_domain%x(1)%compute = domain%x(1)%compute
567 io_domain%x(1)%domain_data = domain%x(1)%domain_data
568 io_domain%x(1)%memory = domain%x(1)%memory
569 io_domain%y(1)%compute = domain%y(1)%compute
570 io_domain%y(1)%domain_data = domain%y(1)%domain_data
571 io_domain%y(1)%memory = domain%y(1)%memory
572 io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin
573 io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end
574 io_domain%x(1)%global%size = io_domain%x(1)%global%end - io_domain%x(1)%global%begin + 1
575 io_domain%x(1)%global%max_size = io_domain%x(1)%global%size
576 io_domain%y(1)%global%begin = domain%y(1)%list(jpos_beg)%compute%begin
577 io_domain%y(1)%global%end = domain%y(1)%list(jpos_end)%compute%end
578 io_domain%y(1)%global%size = io_domain%y(1)%global%end - io_domain%y(1)%global%begin + 1
579 io_domain%y(1)%global%max_size = io_domain%y(1)%global%size
580 io_domain%x(1)%pos = ipos
581 io_domain%y(1)%pos = jpos
582 io_domain%tile_id(1) = io_domain%list(n)%tile_id(1)
583 io_domain%tile_root_pe = io_domain%list(0)%pe
608 xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, &
609 whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
610 integer,
intent(in) :: global_indices(:)
611 integer,
intent(in) :: layout(:)
612 type(domain2d),
intent(inout) :: domain
613 integer,
intent(in),
optional :: pelist(0:)
614 integer,
intent(in),
optional :: xflags, yflags
615 integer,
intent(in),
optional :: xhalo, yhalo
616 integer,
intent(in),
optional :: xextent(0:), yextent(0:)
617 logical,
intent(in),
optional :: maskmap(0:,0:)
618 character(len=*),
intent(in),
optional :: name
619 logical,
intent(in),
optional :: symmetry
620 logical,
intent(in),
optional :: is_mosaic
622 integer,
intent(in),
optional :: memory_size(:)
623 integer,
intent(in),
optional :: whalo, ehalo, shalo, nhalo
629 integer,
intent(in),
optional :: tile_count
633 integer,
intent(in),
optional :: tile_id
634 logical,
intent(in),
optional :: complete
636 integer,
intent(in),
optional :: x_cyclic_offset
639 integer,
intent(in),
optional :: y_cyclic_offset
644 integer :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
645 integer :: whalosz, ehalosz, shalosz, nhalosz
646 integer :: ipos, jpos, pos, tile, nlist, cur_tile_id, cur_comm_id
647 integer :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
648 integer :: x_offset, y_offset, start_pos, nfold
649 logical :: from_mosaic, is_complete
650 logical :: mask(0:layout(1)-1,0:layout(2)-1)
651 integer,
allocatable :: pes(:), pesall(:)
652 integer :: pearray(0:layout(1)-1,0:layout(2)-1)
653 integer :: ibegin(0:layout(1)-1), iend(0:layout(1)-1)
654 integer :: jbegin(0:layout(2)-1), jend(0:layout(2)-1)
655 character(len=8) :: text
656 type(overlapspec),
pointer :: check_T => null()
658 logical :: send(8), recv(8)
661 if( .NOT.module_is_initialized )
call mpp_error( fatal, &
662 &
'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
663 if(
PRESENT(name))
then
664 if(len_trim(name) > name_length)
call mpp_error(fatal, &
665 "mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument name ="//trim(name)// &
666 " is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
669 if(
size(global_indices(:)) .NE. 4)
call mpp_error(fatal, &
670 "mpp_define_domains2D: size of global_indices should be 4 for "//trim(domain%name) )
671 if(
size(layout(:)) .NE. 2)
call mpp_error(fatal,
"mpp_define_domains2D: size of layout should be 2 for "// &
672 & trim(domain%name) )
674 ndivx = layout(1); ndivy = layout(2)
675 isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
677 from_mosaic = .false.
678 if(
present(is_mosaic)) from_mosaic = is_mosaic
680 if(
present(complete)) is_complete = complete
682 if(
present(tile_count)) tile = tile_count
684 if(
present(tile_id)) cur_tile_id = tile_id
687 if(
PRESENT(pelist) )
then
688 allocate( pes(0:
size(pelist(:))-1) )
692 call mpp_get_current_pelist(pesall, commid=cur_comm_id)
694 allocate( pesall(0:
size(pes(:))-1) )
696 call mpp_get_current_pelist(pesall, commid=cur_comm_id)
701 call mpp_get_current_pelist(pes, commid=cur_comm_id)
708 x_offset = 0; y_offset = 0
709 if(
PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
710 if(
PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
711 if(x_offset*y_offset .NE. 0)
call mpp_error(fatal, &
712 'MPP_DEFINE_DOMAINS2D: At least one of x_cyclic_offset and y_cyclic_offset must be zero for '// &
716 if(abs(x_offset) > jeg-jsg+1)
call mpp_error(fatal, &
717 'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset is greater than jeg-jsg+1 for '//trim(domain%name))
718 if(abs(y_offset) > ieg-isg+1)
call mpp_error(fatal, &
719 'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset is greater than ieg-isg+1 for '//trim(domain%name))
722 if( tile > 1 .AND.
size(pes(:)) > 1)
call mpp_error(fatal, &
723 'MPP_DEFINE_DOMAINS2D: there are more than one tile on this pe, '// &
724 'all the tile should be limited on this pe for '//trim(domain%name))
730 do n = 0,
size(pesall(:))-1
731 if(pesall(n) ==
mpp_pe() )
then
736 if(pos<0)
call mpp_error(fatal,
'MPP_DEFINE_DOMAINS2D: mpp_pe() is not in the pesall list')
738 domain%symmetry = .false.
739 if(
present(symmetry)) domain%symmetry = symmetry
740 if(domain%symmetry)
then
741 ishift = 1; jshift = 1
743 ishift = 0; jshift = 0
750 xhalosz = 0; yhalosz = 0
751 if(
present(xhalo)) xhalosz = xhalo
752 if(
present(yhalo)) yhalosz = yhalo
753 whalosz = xhalosz; ehalosz = xhalosz
754 shalosz = yhalosz; nhalosz = yhalosz
755 if(
present(whalo)) whalosz = whalo
756 if(
present(ehalo)) ehalosz = ehalo
757 if(
present(shalo)) shalosz = shalo
758 if(
present(nhalo)) nhalosz = nhalo
762 if(
PRESENT(maskmap) )
then
763 if(
size(maskmap,1).NE.ndivx .OR.
size(maskmap,2).NE.ndivy ) &
764 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout for '// &
765 & trim(domain%name) )
766 mask(:,:) = maskmap(:,:)
770 if( n.NE.
size(pes(:)) )
then
771 write( text,
'(i8)' )n
772 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for ' // &
773 'this layout and maskmap. Use '//text//
' PEs for this domain decomposition for '//trim(domain%name) )
776 memory_xsize = 0; memory_ysize = 0
777 if(
present(memory_size))
then
778 if(
size(memory_size(:)) .NE. 2)
call mpp_error(fatal, &
779 "mpp_define_domains2D: size of memory_size should be 2 for "//trim(domain%name))
780 memory_xsize = memory_size(1)
781 memory_ysize = memory_size(2)
787 nlist =
size(pesall(:))
788 if( .NOT.
Associated(domain%x) )
then
789 allocate(domain%tileList(1))
790 domain%tileList(1)%xbegin = global_indices(1)
791 domain%tileList(1)%xend = global_indices(2)
792 domain%tileList(1)%ybegin = global_indices(3)
793 domain%tileList(1)%yend = global_indices(4)
794 allocate(domain%x(1), domain%y(1) )
795 allocate(domain%tile_id(1))
796 allocate(domain%tile_id_all(1))
797 domain%tile_id = cur_tile_id
798 domain%tile_id_all = cur_tile_id
799 domain%tile_comm_id = cur_comm_id
801 domain%max_ntile_pe = 1
803 domain%rotated_ninety = .false.
804 allocate( domain%list(0:nlist-1) )
806 allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1))
810 domain%initialized = .true.
814 if(pesall(n) == pes(0))
then
821 pearray(:,:) = null_pe
822 ipos = null_pe; jpos = null_pe
828 pearray(i,j) = pes(n)
829 domain%list(m)%x(tile)%compute%begin = ibegin(i)
830 domain%list(m)%x(tile)%compute%end = iend(i)
831 domain%list(m)%y(tile)%compute%begin = jbegin(j)
832 domain%list(m)%y(tile)%compute%end = jend(j)
833 domain%list(m)%x(tile)%compute%size = domain%list(m)%x(tile)%compute%end &
834 & - domain%list(m)%x(tile)%compute%begin + 1
835 domain%list(m)%y(tile)%compute%size = domain%list(m)%y(tile)%compute%end &
836 & - domain%list(m)%y(tile)%compute%begin + 1
837 domain%list(m)%tile_id(tile) = cur_tile_id
838 domain%list(m)%x(tile)%pos = i
839 domain%list(m)%y(tile)%pos = j
840 domain%list(m)%tile_root_pe = pes(0)
841 domain%list(m)%pe = pesall(m)
843 if( pes(n).EQ.
mpp_pe() )
then
855 if( any(pes ==
mpp_pe()) )
then
856 domain%io_layout = layout
857 domain%tile_root_pe = pes(0)
858 domain%comm_id = cur_comm_id
859 if( ipos.EQ.null_pe .OR. jpos.EQ.null_pe ) &
860 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS2D: pelist must include this PE for '//trim(domain%name) )
863 write( errunit, * )
'pe, tile, ipos, jpos=',
mpp_pe(), tile, ipos, jpos,
' pearray(:,jpos)=', &
864 pearray(:,jpos),
' pearray(ipos,:)=', pearray(ipos,:)
869 if (
associated(domain%pearray))
deallocate(domain%pearray)
870 allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
871 domain%pearray = pearray
876 domain_cnt = domain_cnt + int(1,kind=i8_kind)
877 domain%id = domain_cnt*domain_id_base
880 call mpp_define_domains( global_indices(1:2), ndivx, domain%x(tile), &
881 pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
882 call mpp_define_domains( global_indices(3:4), ndivy, domain%y(tile), &
883 pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
884 if( domain%x(tile)%list(ipos)%pe.NE.domain%y(tile)%list(jpos)%pe ) &
885 call mpp_error( fatal, .NE.
'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pedomain%y%list(jpos)%pe.' )
888 if(x_offset .NE. 0 .OR. y_offset .NE. 0)
then
889 if(whalosz .GT. domain%x(tile)%compute%size .OR. ehalosz .GT. domain%x(tile)%compute%size ) &
890 call mpp_error(fatal,
"mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
891 "whalo and ehalo must be no larger than the x-direction computation domain size")
892 if(shalosz .GT. domain%y(tile)%compute%size .OR. nhalosz .GT. domain%y(tile)%compute%size ) &
893 call mpp_error(fatal,
"mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
894 "shalo and nhalo must be no larger than the y-direction computation domain size")
898 if(whalosz .GT. domain%x(tile)%global%size) &
899 call mpp_error(fatal,
"MPP_DEFINE_DOMAINS2D: whalo is greather global domain size")
900 if(ehalosz .GT. domain%x(tile)%global%size) &
901 call mpp_error(fatal,
"MPP_DEFINE_DOMAINS2D: ehalo is greather global domain size")
902 if(shalosz .GT. domain%x(tile)%global%size) &
903 call mpp_error(fatal,
"MPP_DEFINE_DOMAINS2D: shalo is greather global domain size")
904 if(nhalosz .GT. domain%x(tile)%global%size) &
905 call mpp_error(fatal,
"MPP_DEFINE_DOMAINS2D: nhalo is greather global domain size")
910 if(
PRESENT(xflags) )
then
911 if( btest(xflags,west) )
then
913 if(domain%x(tile)%domain_data%begin .LE. domain%x(tile)%global%begin .AND. &
914 domain%x(tile)%compute%begin > domain%x(tile)%global%begin )
then
915 call mpp_error(fatal, &
916 'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded')
918 if( domain%x(tile)%cyclic )
call mpp_error( fatal, &
919 'MPP_DEFINE_DOMAINS: an axis cannot be both folded west and cyclic for '//trim(domain%name) )
920 domain%fold = domain%fold + fold_west_edge
923 if( btest(xflags,east) )
then
925 if(domain%x(tile)%domain_data%end .GE. domain%x(tile)%global%end .AND. &
926 domain%x(tile)%compute%end < domain%x(tile)%global%end )
then
927 call mpp_error(fatal, &
928 'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded')
930 if( domain%x(tile)%cyclic )
call mpp_error( fatal, &
931 'MPP_DEFINE_DOMAINS: an axis cannot be both folded east and cyclic for '//trim(domain%name) )
932 domain%fold = domain%fold + fold_east_edge
936 if(
PRESENT(yflags) )
then
937 if( btest(yflags,south) )
then
939 if(domain%y(tile)%domain_data%begin .LE. domain%y(tile)%global%begin .AND. &
940 domain%y(tile)%compute%begin > domain%y(tile)%global%begin )
then
941 call mpp_error(fatal, &
942 'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded')
944 if( domain%y(tile)%cyclic )
call mpp_error( fatal, &
945 'MPP_DEFINE_DOMAINS: an axis cannot be both folded north and cyclic for '//trim(domain%name))
946 domain%fold = domain%fold + fold_south_edge
949 if( btest(yflags,north) )
then
952 if(whalosz .GT. domain%x(tile)%compute%size .AND. whalosz .GE. domain%x(tile)%global%size/2 ) &
953 call mpp_error(fatal, .GT.
"MPP_DEFINE_DOMAINS2D: north is folded, whalo compute domain size "// &
954 .GE.
"and whalo half of global domain size")
955 if(ehalosz .GT. domain%x(tile)%compute%size .AND. ehalosz .GE. domain%x(tile)%global%size/2 ) &
956 call mpp_error(fatal, .GT.
"MPP_DEFINE_DOMAINS2D: north is folded, ehalo is compute domain size "// &
957 .GE.
"and ehalo half of global domain size")
958 if(shalosz .GT. domain%y(tile)%compute%size .AND. shalosz .GE. domain%x(tile)%global%size/2 ) &
959 call mpp_error(fatal, .GT.
"MPP_DEFINE_DOMAINS2D: north is folded, shalo compute domain size "// &
960 .GE.
"and shalo half of global domain size")
961 if(nhalosz .GT. domain%y(tile)%compute%size .AND. nhalosz .GE. domain%x(tile)%global%size/2 ) &
962 call mpp_error(fatal, .GT.
"MPP_DEFINE_DOMAINS2D: north is folded, nhalo compute domain size "// &
963 .GE.
"and nhalo half of global domain size")
966 if( domain%y(tile)%cyclic )
call mpp_error( fatal, &
967 'MPP_DEFINE_DOMAINS: an axis cannot be both folded south and cyclic for '//trim(domain%name) )
968 domain%fold = domain%fold + fold_north_edge
972 if(nfold > 1)
call mpp_error(fatal, &
973 'MPP_DEFINE_DOMAINS2D: number of folded edge is greater than 1 for '//trim(domain%name) )
976 if( x_offset .NE. 0 .OR. y_offset .NE. 0)
call mpp_error(fatal, &
977 'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition, '//&
978 'x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
980 if( btest(domain%fold,south) .OR. btest(domain%fold,north) )
then
981 if( domain%y(tile)%cyclic )
call mpp_error( fatal, &
982 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
983 if( modulo(domain%x(tile)%global%size,2).NE.0 ) &
984 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS: number of points in X must be even ' // &
985 'when there is a fold in Y for '//trim(domain%name) )
990 if( domain%x(tile)%list(i)%compute%size.NE.domain%x(tile)%list(n-i)%compute%size ) &
991 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS: Folded domain boundaries ' // &
992 'must line up (mirror-symmetric extents) for '//trim(domain%name) )
995 if( btest(domain%fold,west) .OR. btest(domain%fold,east) )
then
996 if( domain%x(tile)%cyclic )
call mpp_error( fatal, &
997 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
998 if( modulo(domain%y(tile)%global%size,2).NE.0 ) &
999 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS: number of points in Y must be even '//&
1000 'when there is a fold in X for '//trim(domain%name) )
1005 if( domain%y(tile)%list(i)%compute%size.NE.domain%y(tile)%list(n-i)%compute%size ) &
1006 call mpp_error( fatal,
'MPP_DEFINE_DOMAINS: Folded domain boundaries must '//&
1007 'line up (mirror-symmetric extents) for '//trim(domain%name) )
1012 if(
mpp_pe().EQ.pes(0) .AND.
PRESENT(name) )
then
1014 write( logunit,
'(/a,i5,a,i5)' )trim(name)//
' domain decomposition: ', ndivx,
' X', ndivy
1015 write( logunit,
'(3x,a)' )
'pe, is, ie, js, je, isd, ied, jsd, jed'
1019 if(is_complete)
then
1020 domain%whalo = whalosz; domain%ehalo = ehalosz
1021 domain%shalo = shalosz; domain%nhalo = nhalosz
1022 if (
associated(domain%update_T))
deallocate(domain%update_T)
1023 if (
associated(domain%update_E))
deallocate(domain%update_E)
1024 if (
associated(domain%update_C))
deallocate(domain%update_C)
1025 if (
associated(domain%update_N))
deallocate(domain%update_N)
1026 allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
1027 domain%update_T%next => null()
1028 domain%update_E%next => null()
1029 domain%update_C%next => null()
1030 domain%update_N%next => null()
1031 if (
associated(domain%check_E))
deallocate(domain%check_E)
1032 if (
associated(domain%check_C))
deallocate(domain%check_C)
1033 if (
associated(domain%check_N))
deallocate(domain%check_N)
1034 allocate(domain%check_E, domain%check_C, domain%check_N )
1035 domain%update_T%nsend = 0
1036 domain%update_T%nrecv = 0
1037 domain%update_C%nsend = 0
1038 domain%update_C%nrecv = 0
1039 domain%update_E%nsend = 0
1040 domain%update_E%nrecv = 0
1041 domain%update_N%nsend = 0
1042 domain%update_N%nrecv = 0
1044 if( btest(domain%fold,south) )
then
1049 else if( btest(domain%fold,west) )
then
1054 else if( btest(domain%fold,east) )
then
1060 call compute_overlaps(domain, center, domain%update_T, check_t, 0, 0, x_offset, y_offset, &
1061 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1062 call compute_overlaps(domain, corner, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
1063 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1064 call compute_overlaps(domain, east, domain%update_E, domain%check_E, ishift, 0, x_offset, y_offset, &
1065 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1066 call compute_overlaps(domain, north, domain%update_N, domain%check_N, 0, jshift, x_offset, y_offset, &
1067 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1069 call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//
" update_T in mpp_define_domains")
1070 call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//
" update_C in mpp_define_domains")
1071 call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//
" update_E in mpp_define_domains")
1072 call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//
" update_N in mpp_define_domains")
1076 if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%ntiles == 1) )
then
1080 if (
associated(domain%bound_E))
deallocate(domain%bound_E)
1081 if (
associated(domain%bound_C))
deallocate(domain%bound_C)
1082 if (
associated(domain%bound_N))
deallocate(domain%bound_N)
1083 allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1088 call set_domain_comm_inf(domain%update_T)
1089 call set_domain_comm_inf(domain%update_E)
1090 call set_domain_comm_inf(domain%update_C)
1091 call set_domain_comm_inf(domain%update_N)
1097 if(debug_message_passing .and. (domain%ncontacts == 0 .OR. domain%ntiles == 1) )
then
1100 call check_message_size(domain, domain%update_T, send, recv,
'T')
1101 call check_message_size(domain, domain%update_E, send, recv,
'E')
1102 call check_message_size(domain, domain%update_C, send, recv,
'C')
1103 call check_message_size(domain, domain%update_N, send, recv,
'N')
1108 if(
mpp_pe() .EQ. pes(0) .AND.
PRESENT(name) )
then
1109 write(*,*) trim(name)//
' domain decomposition'
1110 write(*,
'(a,i4,a,i4,a,i4,a,i4)')
'whalo = ', whalosz,
", ehalo = ", ehalosz,
", shalo = ", shalosz, &
1111 &
", nhalo = ", nhalosz
1112 write (*,110) (domain%x(1)%list(i)%compute%size, i= 0, layout(1)-1)
1113 write (*,120) (domain%y(1)%list(i)%compute%size, i= 0, layout(2)-1)
1114 110
format (
' X-AXIS = ',24i4,/,(11x,24i4))
1115 120
format (
' Y-AXIS = ',24i4,/,(11x,24i4))
1118 deallocate( pes, pesall)
1126 subroutine check_message_size(domain, update, send, recv, position)
1127 type(domain2d),
intent(in) :: domain
1128 type(overlapspec),
intent(in) :: update
1129 logical,
intent(in) :: send(:)
1130 logical,
intent(in) :: recv(:)
1131 character,
intent(in) :: position
1133 integer,
dimension(0:size(domain%list(:))-1) :: msg1, msg2, msg3
1134 integer :: m, n, l, dir, is, ie, js, je, from_pe, msgsize
1137 nlist =
size(domain%list(:))
1142 do m = 1, update%nrecv
1144 do n = 1, update%recv(m)%count
1145 dir = update%recv(m)%dir(n)
1146 if( recv(dir) )
then
1147 is = update%recv(m)%is(n); ie = update%recv(m)%ie(n)
1148 js = update%recv(m)%js(n); je = update%recv(m)%je(n)
1149 msgsize = msgsize + (ie-is+1)*(je-js+1)
1152 from_pe = update%recv(m)%pe
1153 l = from_pe-mpp_root_pe()
1154 call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.false., tag=comm_tag_1)
1158 do m = 1, update%nsend
1160 do n = 1, update%send(m)%count
1161 dir = update%send(m)%dir(n)
1163 is = update%send(m)%is(n); ie = update%send(m)%ie(n)
1164 js = update%send(m)%js(n); je = update%send(m)%je(n)
1165 msgsize = msgsize + (ie-is+1)*(je-js+1)
1168 l = update%send(m)%pe-mpp_root_pe()
1170 call mpp_send( msg3(l), plen=1, to_pe=update%send(m)%pe, tag=comm_tag_1)
1175 if(msg1(m) .NE. msg2(m))
then
1176 print*,
"My pe = ",
mpp_pe(),
",domain name =", trim(domain%name),
",at position=",position,
",from pe=", &
1177 domain%list(m)%pe,
":send size = ", msg1(m),
", recv size = ", msg2(m)
1178 call mpp_error(fatal,
"mpp_define_domains2D: mismatch on send and recv size")
1184 end subroutine check_message_size
1200 subroutine mpp_define_mosaic( global_indices, layout, domain, num_tile, num_contact, tile1, tile2, &
1201 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
1202 pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, &
1203 maskmap, name, memory_size, symmetry, xflags, yflags, tile_id )
1204 integer,
intent(in) :: global_indices(:,:)
1208 integer,
intent(in) :: layout(:,:)
1209 type(domain2d),
intent(inout) :: domain
1210 integer,
intent(in) :: num_tile
1211 integer,
intent(in) :: num_contact
1212 integer,
intent(in) :: tile1(:), tile2(:)
1213 integer,
intent(in) :: istart1(:), iend1(:)
1214 integer,
intent(in) :: jstart1(:), jend1(:)
1215 integer,
intent(in) :: istart2(:), iend2(:)
1216 integer,
intent(in) :: jstart2(:), jend2(:)
1217 integer,
intent(in) :: pe_start(:)
1218 integer,
intent(in) :: pe_end(:)
1219 integer,
intent(in),
optional :: pelist(:)
1220 integer,
intent(in),
optional :: whalo, ehalo, shalo, nhalo
1221 integer,
intent(in),
optional :: xextent(:,:), yextent(:,:)
1222 logical,
intent(in),
optional :: maskmap(:,:,:)
1223 character(len=*),
intent(in),
optional :: name
1224 integer,
intent(in),
optional :: memory_size(2)
1225 logical,
intent(in),
optional :: symmetry
1226 integer,
intent(in),
optional :: xflags, yflags
1227 integer,
intent(in),
optional :: tile_id(:)
1229 integer :: n, m, ndivx, ndivy, nc, nlist, nt, pos, n1, n2
1230 integer :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz, t1, t2, tile
1231 integer :: flags_x, flags_y
1232 logical,
allocatable :: mask(:,:)
1233 integer,
allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
1234 integer,
allocatable :: tile_id_local(:)
1235 logical :: is_symmetry
1236 integer,
allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
1237 integer,
allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:)
1238 real,
allocatable :: refine1(:), refine2(:)
1240 logical :: send(8), recv(8)
1243 mosaic_defined = .true.
1245 if(
size(global_indices, 1) .NE. 4)
call mpp_error(fatal, &
1246 'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
1248 if(
size(global_indices, 2) .NE. num_tile)
call mpp_error(fatal, &
1249 'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
1251 if(
size(layout, 1) .NE. 2)
call mpp_error(fatal, &
1252 'mpp_domains_define.inc: The size of first dimension of layout is not 2')
1253 if(
size(layout,2) .NE. num_tile)
call mpp_error(fatal, &
1254 'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
1258 allocate(pes(0:nlist-1))
1259 if(
present(pelist))
then
1260 if( nlist .NE.
size(pelist(:)))
call mpp_error(fatal, &
1261 'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
1264 call mpp_get_current_pelist(pes, commid=domain%comm_id)
1267 if(pes(n) - pes(n-1) .NE. 1)
call mpp_error(fatal, &
1268 'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
1271 is_symmetry = .false.
1272 if(
present(symmetry)) is_symmetry = symmetry
1274 if(
size(pe_start(:)) .NE. num_tile .OR.
size(pe_end(:)) .NE. num_tile )
call mpp_error(fatal, &
1275 'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
1277 if( any( pe_start < pes(0) ) )
call mpp_error(fatal, &
1278 &
'mpp_domains_define.inc: not all the pe_start are in the pelist')
1279 if( any( pe_end > pes(nlist-1)) )
call mpp_error(fatal, &
1280 &
'mpp_domains_define.inc: not all the pe_end are in the pelist')
1283 allocate( ntile_per_pe(0:nlist-1) )
1286 do m = pe_start(n) - mpp_root_pe(), pe_end(n) - mpp_root_pe()
1287 ntile_per_pe(m) = ntile_per_pe(m) + 1
1290 if(any(ntile_per_pe == 0))
call mpp_error(fatal, &
1291 'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
1294 if(
PRESENT(xextent) )
then
1295 if(
size(xextent,1) .GT. maxval(layout(1,:)) )
call mpp_error(fatal, &
1296 'mpp_domains_define.inc: size mismatch between xextent and layout')
1297 if(
size(xextent,2) .NE. num_tile)
call mpp_error(fatal, &
1298 'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
1300 if(
PRESENT(yextent) )
then
1301 if(
size(yextent,1) .GT. maxval(layout(2,:)) )
call mpp_error(fatal, &
1302 'mpp_domains_define.inc: size mismatch between yextent and layout')
1303 if(
size(yextent,2) .NE. num_tile)
call mpp_error(fatal, &
1304 'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
1311 if(
present(maskmap))
then
1312 if(
size(maskmap,1) .GT. maxval(layout(1,:)) .or.
size(maskmap,2) .GT. maxval(layout(2,:))) &
1313 call mpp_error(fatal,
'mpp_domains_define.inc: size mismatch between maskmap and layout')
1314 if(
size(maskmap,3) .NE. num_tile)
call mpp_error(fatal, &
1315 'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
1318 if (
associated(domain%tileList))
deallocate(domain%tileList)
1319 allocate(domain%tileList(num_tile))
1321 domain%tileList(n)%xbegin = global_indices(1,n)
1322 domain%tileList(n)%xend = global_indices(2,n)
1323 domain%tileList(n)%ybegin = global_indices(3,n)
1324 domain%tileList(n)%yend = global_indices(4,n)
1327 nt = ntile_per_pe(
mpp_pe()-mpp_root_pe())
1328 if (
associated(domain%tile_id))
deallocate(domain%tile_id)
1329 if (
associated(domain%x))
deallocate(domain%x)
1330 if (
associated(domain%y))
deallocate(domain%y)
1331 if (
associated(domain%list))
deallocate(domain%list)
1332 allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) )
1333 allocate(domain%list(0:nlist-1))
1336 nt = ntile_per_pe(n)
1337 allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt))
1342 if(
PRESENT(tile_id) )
then
1343 if(
size(tile_id(:)) .NE. num_tile)
then
1344 call mpp_error(fatal, .NE.
"mpp_domains_define.inc: size(tile_id) num_tile")
1347 allocate(tile_id_local(num_tile))
1355 if(
PRESENT(tile_id))
then
1356 tile_id_local(n) = tile_id(n)
1358 tile_id_local(n) = n
1364 if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n))
then
1366 domain%tile_id(pos) = tile_id_local(n)
1370 if (
associated(domain%tile_id_all))
deallocate(domain%tile_id_all)
1371 allocate(domain%tile_id_all(num_tile))
1372 domain%tile_id_all(:) = tile_id_local(:)
1374 domain%initialized = .true.
1375 domain%rotated_ninety = .false.
1376 domain%ntiles = num_tile
1377 domain%max_ntile_pe = maxval(ntile_per_pe)
1378 domain%ncontacts = num_contact
1380 deallocate(ntile_per_pe)
1382 allocate(tile_count(pes(0):pes(0)+nlist-1))
1385 domain%tile_comm_id=0
1387 allocate(mask(layout(1,n), layout(2,n)))
1388 allocate(pelist_tile(pe_start(n):pe_end(n)) )
1389 tile_count(pe_start(n)) = tile_count(pe_start(n)) + 1
1390 do m = pe_start(n), pe_end(n)
1394 if (any(pelist_tile == pe))
then
1398 if(
present(maskmap)) mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
1399 ndivx = layout(1,n); ndivy = layout(2,n)
1400 allocate(xext(ndivx), yext(ndivy))
1402 if(
present(xextent)) xext = xextent(1:ndivx,n)
1403 if(
present(yextent)) yext = yextent(1:ndivy,n)
1406 if(num_tile == 1)
then
1409 if(
PRESENT(xflags)) flags_x = xflags
1410 if(
PRESENT(yflags)) flags_y = yflags
1411 do m = 1, num_contact
1412 if(istart1(m) == iend1(m) )
then
1413 if(istart2(m) .NE. iend2(m) )
call mpp_error(fatal, &
1414 "mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
1415 if(istart1(m) == istart2(m) )
then
1416 if(istart1(m) == global_indices(1,n) )
then
1417 if(.NOT. btest(flags_x,west) ) flags_x = flags_x + fold_west_edge
1418 else if(istart1(m) == global_indices(2,n) )
then
1419 if(.NOT. btest(flags_x,east) ) flags_x = flags_x + fold_east_edge
1421 call mpp_error(fatal,
"mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1422 "istart1 should equal global_indices(1) or global_indices(2)")
1425 if(.NOT. btest(flags_x,cyclic)) flags_x = flags_x + cyclic_global_domain
1427 else if( jstart1(m) == jend1(m) )
then
1428 if(jstart2(m) .NE. jend2(m) )
call mpp_error(fatal, &
1429 "mpp_domains_define: for one tile mosaic, when jstart1=jend1, jstart2 must equal jend2")
1430 if(jstart1(m) == jstart2(m) )
then
1431 if(jstart1(m) == global_indices(3,n) )
then
1432 if(.NOT. btest(flags_y,south) ) flags_y = flags_y + fold_south_edge
1433 else if(jstart1(m) == global_indices(4,n) )
then
1434 if(.NOT. btest(flags_y,north) ) flags_y = flags_y + fold_north_edge
1436 call mpp_error(fatal,
"mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1437 "istart1 should equal global_indices(1) or global_indices(2)")
1440 if(.NOT. btest(flags_y,cyclic)) flags_y = flags_y + cyclic_global_domain
1443 call mpp_error(fatal, &
1444 "mpp_domains_define: for one tile mosaic, invalid boundary contact")
1447 call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, xflags = flags_x, &
1448 yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1449 xextent=xext, yextent=yext, maskmap=mask, name=name, symmetry=is_symmetry, &
1450 memory_size = memory_size, is_mosaic = .true., tile_id=tile_id_local(n))
1452 call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, &
1453 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
1454 maskmap=mask, name=name, symmetry=is_symmetry, memory_size = memory_size, &
1455 is_mosaic = .true., tile_count = tile_count(pe_start(n)), tile_id=tile_id_local(n), &
1456 complete = n==num_tile)
1458 deallocate(mask, xext, yext, pelist_tile)
1461 deallocate(pes, tile_count, tile_id_local)
1463 if(num_contact == 0 .OR. num_tile == 1)
return
1467 allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
1468 allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
1469 allocate(isglist(num_tile), ieglist(num_tile), jsglist(num_tile), jeglist(num_tile) )
1470 allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
1473 isglist(n) = domain%tileList(n)%xbegin; ieglist(n) = domain%tileList(n)%xend
1474 jsglist(n) = domain%tileList(n)%ybegin; jeglist(n) = domain%tileList(n)%yend
1479 do n = 1, num_contact
1482 is1(n) = istart1(n) + isglist(t1) - 1; ie1(n) = iend1(n) + isglist(t1) - 1
1483 js1(n) = jstart1(n) + jsglist(t1) - 1; je1(n) = jend1(n) + jsglist(t1) - 1
1484 is2(n) = istart2(n) + isglist(t2) - 1; ie2(n) = iend2(n) + isglist(t2) - 1
1485 js2(n) = jstart2(n) + jsglist(t2) - 1; je2(n) = jend2(n) + jsglist(t2) - 1
1486 call check_alignment( is1(n), ie1(n), js1(n), je1(n), isglist(t1), ieglist(t1), jsglist(t1), &
1487 & jeglist(t1), align1(n))
1488 call check_alignment( is2(n), ie2(n), js2(n), je2(n), isglist(t2), ieglist(t2), jsglist(t2), &
1489 & jeglist(t2), align2(n))
1490 if( (align1(n) == west .or. align1(n) == east ) .NEQV. (align2(n) == west .or. align2(n) == east ) )&
1491 domain%rotated_ninety=.true.
1495 do n = 1, num_contact
1496 n1 = max(abs(iend1(n) - istart1(n)), abs(jend1(n) - jstart1(n)) ) + 1
1497 n2 = max(abs(iend2(n) - istart2(n)), abs(jend2(n) - jstart2(n)) ) + 1
1498 refine1(n) = real(n2)/n1
1499 refine2(n) = real(n1)/n2
1502 whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
1503 if(
present(whalo)) whalosz = whalo
1504 if(
present(ehalo)) ehalosz = ehalo
1505 if(
present(shalo)) shalosz = shalo
1506 if(
present(nhalo)) nhalosz = nhalo
1507 xhalosz = max(whalosz, ehalosz)
1508 yhalosz = max(shalosz, nhalosz)
1511 call define_contact_point( domain, center, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
1512 is1, ie1, js1, je1, is2, ie2, js2, je2, isglist, ieglist, jsglist, jeglist )
1518 call set_domain_comm_inf(domain%update_T)
1519 call set_domain_comm_inf(domain%update_E)
1520 call set_domain_comm_inf(domain%update_C)
1521 call set_domain_comm_inf(domain%update_N)
1525 do m = 1,
size(domain%tile_id(:))
1526 tile = domain%tile_id(m)
1527 do n = 1, num_contact
1528 if( tile1(n) == tile )
then
1529 if(align1(n) == east ) domain%x(m)%goffset = 0
1530 if(align1(n) == north) domain%y(m)%goffset = 0
1532 if( tile2(n) == tile )
then
1533 if(align2(n) == east ) domain%x(m)%goffset = 0
1534 if(align2(n) == north) domain%y(m)%goffset = 0
1538 call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//
" update_T in mpp_define_mosaic")
1539 call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//
" update_C in mpp_define_mosaic")
1540 call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//
" update_E in mpp_define_mosaic")
1541 call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//
" update_N in mpp_define_mosaic")
1544 if(debug_update_level .NE. no_check)
then
1549 if(domain%symmetry)
then
1550 if (
associated(domain%bound_E))
deallocate(domain%bound_E)
1551 if (
associated(domain%bound_C))
deallocate(domain%bound_C)
1552 if (
associated(domain%bound_N))
deallocate(domain%bound_N)
1553 allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1557 call check_overlap_pe_order(domain, domain%bound_C, trim(domain%name)//
" bound_C")
1558 call check_overlap_pe_order(domain, domain%bound_E, trim(domain%name)//
" bound_E")
1559 call check_overlap_pe_order(domain, domain%bound_N, trim(domain%name)//
" bound_N")
1565 if(debug_message_passing)
then
1568 call check_message_size(domain, domain%update_T, send, recv,
'T')
1569 call check_message_size(domain, domain%update_C, send, recv,
'C')
1570 call check_message_size(domain, domain%update_E, send, recv,
'E')
1571 call check_message_size(domain, domain%update_N, send, recv,
'N')
1576 deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2 )
1577 deallocate(isglist, ieglist, jsglist, jeglist, refine1, refine2 )
1593 subroutine compute_overlaps( domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
1594 whalo, ehalo, shalo, nhalo )
1595 type(domain2d),
intent(inout) :: domain
1596 type(overlapspec),
intent(inout),
pointer :: update
1597 type(overlapspec),
intent(inout),
pointer :: check
1598 integer,
intent(in) :: position, ishift, jshift
1599 integer,
intent(in) :: x_cyclic_offset, y_cyclic_offset
1600 integer,
intent(in) :: whalo, ehalo, shalo, nhalo
1602 integer :: i, m, n, nlist, tMe, tNbr, dir
1603 integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
1604 integer :: isg, ieg, jsg, jeg, ioff, joff
1605 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
1606 integer :: ism, iem, jsm, jem
1607 integer :: is2, ie2, js2, je2
1608 integer :: is3, ie3, js3, je3
1609 integer :: isd3, ied3, jsd3, jed3
1610 integer :: isd2, ied2, jsd2, jed2
1611 logical :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
1612 type(overlap_type) :: overlap
1613 type(overlap_type),
pointer :: overlapList(:)=>null()
1614 type(overlap_type),
pointer :: checkList(:)=>null()
1615 integer :: nsend, nrecv
1616 integer :: nsend_check, nrecv_check
1618 logical :: set_check
1623 if(
size(domain%x(:)) > 1)
return
1626 if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0)
return
1629 nlist =
size(domain%list(:))
1631 if(
ASSOCIATED(check)) set_check = .true.
1632 allocate(overlaplist(maxlist) )
1633 if(set_check)
allocate(checklist(maxlist) )
1636 call allocate_update_overlap( overlap, maxoverlap)
1638 call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
1639 call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position )
1640 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
1642 update%xbegin = ism; update%xend = iem
1643 update%ybegin = jsm; update%yend = jem
1645 check%xbegin = ism; check%xend = iem
1646 check%ybegin = jsm; check%yend = jem
1648 update%whalo = whalo; update%ehalo = ehalo
1649 update%shalo = shalo; update%nhalo = nhalo
1653 middle = (isg+ieg)/2+1
1655 folded_north = btest(domain%fold,north)
1656 if( btest(domain%fold,south) .OR. btest(domain%fold,east) .OR. btest(domain%fold,west) )
then
1657 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition "&
1658 &//
"is not supported, please use other version of compute_overlaps for "//trim(domain%name))
1665 m = mod( domain%pos+list, nlist )
1666 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
1669 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
1670 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
1672 if( domain%symmetry .AND. (position == north .OR. position == corner ) &
1673 .AND. ( jsc == je .or. jec == js ) )
then
1678 if( je == jeg .AND. folded_north .AND. (position == corner .OR. position == north) )
then
1679 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1680 isg, ieg, dir, ishift, position, ioff, middle)
1682 if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0)
then
1683 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1684 isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
1686 if( ie.GT.ieg )
then
1687 if( domain%x(tme)%cyclic .AND. iec.LT.is )
then
1688 is = is-ioff; ie = ie-ioff
1692 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1693 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1700 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
1701 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1702 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1705 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1706 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
1707 if(je .LT. jsg)
then
1708 if( domain%y(tme)%cyclic )
then
1709 js = js + joff; je = je + joff
1711 else if(js .Lt. jsg)
then
1712 if( domain%y(tme)%cyclic )
then
1713 js2 = js + joff; je2 = jsg-1+joff
1717 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1718 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1719 if(je2 .GE. js2)
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1720 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1723 if( domain%x(tme)%cyclic .AND. iec.LT.is )
then
1724 is = is-ioff; ie = ie-ioff
1725 need_adjust_1 = .false.
1726 if(jsg .GT. js)
then
1727 if( domain%y(tme)%cyclic .AND. je.LT.jsc )
then
1728 js = js+joff; je = je+joff
1729 need_adjust_2 = .false.
1730 if(x_cyclic_offset .NE. 0)
then
1732 else if(y_cyclic_offset .NE. 0)
then
1738 need_adjust_3 = .false.
1742 if( need_adjust_3 .AND. jsg.GT.js )
then
1743 if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. je.LT.jsc )
then
1744 js = js+joff; je = je+joff
1745 if(need_adjust_1 .AND. ie.LE.ieg)
then
1750 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1755 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
1756 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1759 if( domain%y(tme)%cyclic .AND. je.LT.jsc )
then
1760 js = js+joff; je = je+joff
1763 else if (jsg .GT. js)
then
1764 if( domain%y(tme)%cyclic)
then
1765 js2 = js + joff; je2 = jsg-1+joff
1770 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1771 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1772 if(je2 .GE. js2)
call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1773 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1777 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1778 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1779 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1780 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1781 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
1782 if(je .LT. jsg)
then
1783 if( domain%y(tme)%cyclic )
then
1784 js = js + joff; je = je + joff
1786 else if(js .Lt. jsg)
then
1787 if( domain%y(tme)%cyclic )
then
1788 js2 = js + joff; je2 = jsg-1+joff
1792 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1793 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1794 if(je2 .GE. js2)
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1795 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1798 if( domain%x(tme)%cyclic .AND. ie.LT.isc )
then
1799 is = is+ioff; ie = ie+ioff
1800 need_adjust_1 = .false.
1801 if(jsg .GT. js)
then
1802 if( domain%y(tme)%cyclic .AND. je.LT.jsc )
then
1803 js = js+joff; je = je+joff
1804 need_adjust_2 = .false.
1805 if(x_cyclic_offset .NE. 0)
then
1807 else if(y_cyclic_offset .NE. 0)
then
1813 need_adjust_3 = .false.
1817 if( need_adjust_3 .AND. jsg.GT.js )
then
1818 if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. je.LT.jsc )
then
1819 js = js+joff; je = je+joff
1820 if(need_adjust_1 .AND. isg.LE.is )
then
1825 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1830 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1831 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
1835 if( je == jeg .AND. folded_north .AND. (position == corner .OR. position == north))
then
1836 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1837 isg, ieg, dir, ishift, position, ioff, middle)
1839 if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0)
then
1840 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1841 isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
1844 if( domain%x(tme)%cyclic .AND. ie.LT.isc )
then
1845 is = is+ioff; ie = ie+ioff
1849 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1850 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1856 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1857 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
1858 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1859 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
1861 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
1862 if(js .GT. jeg)
then
1863 if( domain%y(tme)%cyclic )
then
1864 js = js-joff; je = je-joff
1865 else if(folded_north )
then
1867 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1869 else if(je .GT. jeg)
then
1870 if( domain%y(tme)%cyclic )
then
1871 is2 = is; ie2 = ie; js2 = js; je2 = jeg
1872 js = jeg+1-joff; je = je -joff
1873 else if(folded_north)
then
1875 is2 = is; ie2 = ie; js2 = js; je2 = jeg
1877 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1878 if( is .GT. ieg)
then
1879 is = is - ioff; ie = ie - ioff
1880 else if( ie .GT. ieg )
then
1881 is3 = is; ie3 = ieg; js3 = js; je3 = je
1882 is = ieg+1-ioff; ie = ie - ioff
1887 if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == corner .OR. position == north))
then
1888 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1889 isg, ieg, dir, ishift, position, ioff, middle)
1891 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1892 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
1894 if(ie3 .GE. is3)
call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
1895 isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
1896 if(ie2 .GE. is2)
then
1897 if(je2 == jeg .AND. jec == jeg .AND. folded_north.AND.(position == corner .OR. position == north))
then
1898 call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1899 isg, ieg, dir, ishift, position, ioff, middle)
1901 call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1902 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1906 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1908 if( domain%x(tme)%cyclic .AND. ie.LT.isc )
then
1909 is = is+ioff; ie = ie+ioff
1910 need_adjust_1 = .false.
1911 if(je .GT. jeg)
then
1912 if( domain%y(tme)%cyclic .AND. jec.LT.js )
then
1913 js = js-joff; je = je-joff
1914 need_adjust_2 = .false.
1915 if(x_cyclic_offset .NE. 0)
then
1917 else if(y_cyclic_offset .NE. 0)
then
1923 need_adjust_3 = .false.
1928 if( need_adjust_3 .AND. je.GT.jeg )
then
1929 if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. jec.LT.js )
then
1930 js = js-joff; je = je-joff
1931 if( need_adjust_1 .AND. isg.LE.is)
then
1934 else if( folded_north )
then
1936 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1939 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1940 isg, ieg, jsg, jeg, dir)
1947 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
1948 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
1953 if( domain%symmetry .AND. (position == east .OR. position == corner ) &
1954 .AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) )
then
1958 if( js .GT. jeg)
then
1959 if( domain%y(tme)%cyclic .AND. jec.LT.js )
then
1960 js = js-joff; je = je-joff
1962 else if( folded_north )
then
1964 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1966 else if( je.GT.jeg )
then
1967 if( domain%y(tme)%cyclic)
then
1968 is2 = is; ie2 = ie; js2 = js; je2 = jeg
1969 js = jeg+1-joff; je = je - joff
1970 else if( folded_north )
then
1972 is2 = is; ie2 = ie; js2 = js; je2 = jeg
1974 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1977 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
1978 if( je == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))
then
1979 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1980 isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1982 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1983 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, domain%symmetry)
1986 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1987 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1990 if(ie2 .GE. is2)
then
1991 if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))
then
1992 call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1993 isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1995 call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1996 isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
2002 if(is .LT. isg .AND. domain%x(tme)%cyclic)
then
2013 if( folded_north .AND. (position == north .OR. position == corner) &
2014 .AND. domain%x(tme)%pos .LT. (
size(domain%x(tme)%list(:))+1)/2 )
then
2015 if( domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .GE. jeg .AND. isc .LE. middle)
then
2017 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
2018 is = max(is, middle)
2019 select case (position)
2021 i=is; is = isg+ieg-ie; ie = isg+ieg-i
2023 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2025 call insert_update_overlap(overlap, domain%list(m)%pe, &
2026 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
2028 if(debug_update_level .NE. no_check .AND. set_check)
then
2029 je = domain%list(m)%y(tnbr)%compute%end+jshift;
2031 is = max(is, isc); ie = min(ie, iec)
2032 js = max(js, jsc); je = min(je, jec)
2033 if(ie.GE.is .AND. je.GE.js )
then
2034 nsend_check = nsend_check+1
2035 if(nsend_check >
size(checklist(:)) )
then
2036 call expand_check_overlap_list(checklist, nlist)
2038 call allocate_check_overlap(checklist(nsend_check), 1)
2039 call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
2040 tme, 4, one_hundred_eighty, is, ie, js, je)
2048 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
2049 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
2050 is2 = 0; ie2=-1; js2=0; je2=-1
2051 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2052 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2054 if(js .GT. jeg)
then
2055 if( domain%y(tme)%cyclic )
then
2056 js = js-joff; je = je-joff
2057 else if(folded_north )
then
2059 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2061 else if(je .GT. jeg)
then
2062 if( domain%y(tme)%cyclic )
then
2063 is2 = is; ie2 = ie; js2 = js; je2 = jeg
2064 js = jeg+1-joff; je = je -joff
2065 else if(folded_north)
then
2067 is2 = is; ie2 = ie; js2 = js; je2 = jeg
2069 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2071 if( ie .LT. isg )
then
2072 is = is+ioff; ie = ie+ioff
2073 else if( is .LT. isg)
then
2074 is3 = isg; ie3 = ie; js3 = js; je3 = je
2075 is = is+ioff; ie = isg-1+ioff;
2079 if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == corner .OR. position == north))
then
2080 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2081 isg, ieg, dir, ishift, position, ioff, middle)
2083 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2084 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2086 if(ie3 .GE. is3)
call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
2087 isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2088 if(ie2 .GE. is2)
then
2089 if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))
then
2090 call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2091 isg, ieg, dir, ishift, position, ioff, middle)
2093 call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2094 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2098 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2100 if( domain%x(tme)%cyclic .AND. iec.LT.is )
then
2101 is = is-ioff; ie = ie-ioff
2102 need_adjust_1 = .false.
2103 if(je .GT. jeg)
then
2104 if( domain%y(tme)%cyclic .AND. jec.LT.js )
then
2105 js = js-joff; je = je-joff
2106 need_adjust_2 = .false.
2107 if(x_cyclic_offset .NE. 0)
then
2109 else if(y_cyclic_offset .NE. 0)
then
2115 need_adjust_3 = .false.
2120 if( need_adjust_3 .AND. je.GT.jeg )
then
2121 if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. jec.LT.js )
then
2122 js = js-joff; je = je-joff
2123 if( need_adjust_1 .AND. ie.LE.ieg)
then
2126 else if( folded_north )
then
2128 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2131 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2132 isg, ieg, jsg, jeg, dir)
2137 if( overlap%count > 0)
then
2139 if(nsend >
size(overlaplist(:)) )
then
2140 call mpp_error(note,
'mpp_domains_define.inc(compute_overlaps): overlapList for send is expanded')
2141 call expand_update_overlap_list(overlaplist, nlist)
2143 call add_update_overlap( overlaplist(nsend), overlap)
2144 call init_overlap_type(overlap)
2148 if(debug_message_passing)
then
2152 write(iunit, *)
"********to_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
2153 do n = 1, overlaplist(m)%count
2154 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
2155 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
2158 if(nsend >0)
flush(iunit)
2163 if (
associated(update%send))
deallocate(update%send)
2164 allocate(update%send(nsend))
2165 update%nsend = nsend
2167 call add_update_overlap( update%send(m), overlaplist(m) )
2171 if(nsend_check>0)
then
2172 check%nsend = nsend_check
2173 if (
associated(check%send))
deallocate(check%send)
2174 allocate(check%send(nsend_check))
2175 do m = 1, nsend_check
2180 do m = 1,
size(overlaplist(:))
2181 call deallocate_overlap_type(overlaplist(m))
2184 if(debug_update_level .NE. no_check .AND. set_check)
then
2185 do m = 1,
size(checklist(:))
2186 call deallocate_overlap_type(checklist(m))
2190 isgd = isg - domain%whalo
2191 iegd = ieg + domain%ehalo
2192 jsgd = jsg - domain%shalo
2193 jegd = jeg + domain%nhalo
2199 m = mod( domain%pos+nlist-list, nlist )
2200 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
2201 isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
2202 jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
2205 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2206 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
2207 is=isc; ie=iec; js=jsc; je=jec
2208 if( domain%symmetry .AND. (position == north .OR. position == corner ) &
2209 .AND. ( jsd == je .or. jed == js ) )
then
2214 if( jed == jeg .AND. folded_north .AND. (position == corner .OR. position == north) )
then
2215 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2216 isg, ieg, dir, ishift, position, ioff, middle)
2218 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2219 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2220 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2222 if( ied.GT.ieg )
then
2223 if( domain%x(tme)%cyclic .AND. ie.LT.isd )
then
2224 is = is+ioff; ie = ie+ioff
2228 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2229 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2236 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2237 jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2238 is=isc; ie=iec; js=jsc; je=jec
2241 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2242 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2243 if(jed .LT. jsg)
then
2244 if( domain%y(tme)%cyclic )
then
2245 js = js-joff; je = je-joff
2247 else if(jsd .LT. jsg)
then
2248 if( domain%y(tme)%cyclic )
then
2249 js2 = js-joff; je2 = je-joff
2252 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2253 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2254 if(je2 .GE. js2)
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2255 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2257 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2258 if( jsd.LT.jsg )
then
2259 if( domain%y(tme)%cyclic .AND. js.GT.jed )
then
2260 js = js-joff; je = je-joff
2261 need_adjust_1 = .false.
2262 if( ied.GT.ieg )
then
2263 if( domain%x(tme)%cyclic .AND. ie.LT.isd )
then
2264 is = is+ioff; ie = ie+ioff
2265 need_adjust_2 = .false.
2266 if(x_cyclic_offset .NE. 0)
then
2268 else if(y_cyclic_offset .NE. 0)
then
2274 need_adjust_3 = .false.
2278 if( need_adjust_3 .AND. ied.GT.ieg )
then
2279 if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. ie.LT.isd )
then
2280 is = is+ioff; ie = ie+ioff
2281 if( need_adjust_1 .AND. jsd.GE.jsg )
then
2286 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2287 isg, ieg, jsg, jeg, dir)
2292 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
2293 jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2294 is=isc; ie=iec; js=jsc; je=jec
2296 if( jed .LT. jsg)
then
2297 if( domain%y(tme)%cyclic )
then
2298 js = js-joff; je = je-joff
2301 else if( jsd.LT.jsg )
then
2302 if( domain%y(tme)%cyclic)
then
2303 js2 = js-joff; je2 = je-joff
2306 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2307 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2308 if(je2 .GE. js2)
call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2309 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2313 isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2314 jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2315 is=isc; ie=iec; js=jsc; je=jec
2316 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2317 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2318 if( ied.LT.isg )
then
2319 if( domain%x(tme)%cyclic )
then
2320 is = is-ioff; ie = ie-ioff
2322 else if (isd.LT.isg )
then
2323 if( domain%x(tme)%cyclic )
then
2324 is2 = is-ioff; ie2 = ie-ioff
2327 if( jed.LT.jsg )
then
2328 if( domain%y(tme)%cyclic )
then
2329 js = js-joff; je = je-joff
2331 else if( jsd.LT.jsg )
then
2332 if( domain%y(tme)%cyclic )
then
2333 js2 = js-joff; je2 = je-joff
2337 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2338 if( jsd.LT.jsg )
then
2339 if( domain%y(tme)%cyclic .AND. js.GT.jed )
then
2340 js = js-joff; je = je-joff
2341 need_adjust_1 = .false.
2342 if( isd.LT.isg )
then
2343 if( domain%x(tme)%cyclic .AND. is.GT.ied )
then
2344 is = is-ioff; ie = ie-ioff
2345 need_adjust_2 = .false.
2346 if(x_cyclic_offset .NE. 0)
then
2348 else if(y_cyclic_offset .NE. 0)
then
2354 need_adjust_3 = .false.
2358 if( need_adjust_3 .AND. isd.LT.isg )
then
2359 if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. is.GT.ied )
then
2360 is = is-ioff; ie = ie-ioff
2361 if(need_adjust_1 .AND. jsd.GE.jsg)
then
2367 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2368 isg, ieg, jsg, jeg, dir)
2370 if(ie2 .GE. is2)
call fill_overlap(overlap, domain, m, is2, ie2, js, je, isd, ied, jsd, jed, &
2371 isg, ieg, jsg, jeg, dir)
2372 if(je2 .GE. js2)
call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2373 isg, ieg, jsg, jeg, dir)
2375 if(ie2 .GE. is2 .AND. je2 .GE. js2)
call fill_overlap(overlap, domain, m, is2, ie2, js2, je2, isd, ied, jsd, &
2376 & jed, isg, ieg, jsg, jeg, dir)
2381 isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2382 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
2383 is=isc; ie=iec; js=jsc; je=jec
2387 if( jed == jeg .AND. folded_north .AND. (position == corner .OR. position == north) )
then
2388 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2389 isg, ieg, dir, ishift, position, ioff, middle)
2391 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2392 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2393 isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
2395 if( isd.LT.isg )
then
2396 if( domain%x(tme)%cyclic .AND. is.GT.ied )
then
2397 is = is-ioff; ie = ie-ioff
2401 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2402 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2409 isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2410 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2411 is=isc; ie=iec; js=jsc; je=jec
2412 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2413 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2414 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2416 if( jsd .GT. jeg )
then
2417 if( domain%y(tme)%cyclic .AND. je.LT.jsd )
then
2418 js = js+joff; je = je+joff
2420 else if( folded_north )
then
2422 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2424 else if( jed.GT.jeg )
then
2425 if( domain%y(tme)%cyclic)
then
2426 is2 = is; ie2 = ie; js2 = js; je2 = je
2427 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2428 js = js + joff; je = je + joff
2430 else if( folded_north )
then
2432 is2 = is; ie2 = ie; js2 = js; je2 = je
2433 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2435 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2436 if(isd < isg .and. ied .GE. isg .and. domain%symmetry)
then
2437 isd3 = isd; ied3 = isg-1
2438 jsd3 = jsd; jed3 = jed
2439 is3 = is-ioff; ie3=ie-ioff
2446 if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2447 .AND. (position == corner .OR. position == north))
then
2448 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2449 isg, ieg, dir, ishift, position, ioff, middle)
2451 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2452 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2455 if(ie3 .GE. is3)
call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2456 & jed3, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2458 if(ie2 .GE. is2)
then
2459 if( jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2460 .AND. (position == corner .OR. position == north))
then
2461 call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2462 isg, ieg, dir, ishift, position, ioff, middle)
2464 call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2465 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2469 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2470 if( jed.GT.jeg )
then
2471 if( domain%y(tme)%cyclic .AND. je.LT.jsd )
then
2472 js = js+joff; je = je+joff
2473 need_adjust_1 = .false.
2474 if( isd.LT.isg )
then
2475 if( domain%x(tme)%cyclic .AND. is.GE.ied )
then
2476 is = is-ioff; ie = ie-ioff
2477 need_adjust_2 = .false.
2478 if(x_cyclic_offset .NE. 0)
then
2480 else if(y_cyclic_offset .NE. 0)
then
2486 need_adjust_3 = .false.
2488 else if( folded_north )
then
2490 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2493 if( need_adjust_3 .AND. isd.LT.isg )
then
2494 if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. is.GE.ied )
then
2495 is = is-ioff; ie = ie-ioff
2496 if( need_adjust_1 .AND. jed.LE.jeg )
then
2501 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2502 isg, ieg, jsg, jeg, dir)
2506 if(is .LT. isg .AND. domain%x(tme)%cyclic)
then
2508 call insert_update_overlap(overlap, domain%list(m)%pe, &
2509 is, is, js, je, isd, ied, jsd, jed, dir, folded )
2515 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
2516 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2517 is=isc; ie=iec; js=jsc; je=jec
2521 if( domain%symmetry .AND. (position == east .OR. position == corner ) &
2522 .AND. (isd == ie .or. ied == is ) .AND. (.not. folded_north) )
then
2526 if( jsd .GT. jeg )
then
2527 if( domain%y(tme)%cyclic .AND. je.LT.jsd )
then
2528 js = js+joff; je = je+joff
2530 else if( folded_north )
then
2532 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2534 else if( jed.GT.jeg )
then
2535 if( domain%y(tme)%cyclic)
then
2536 is2 = is; ie2 = ie; js2 = js; je2 = je
2537 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2538 js = js + joff; je = je + joff
2540 else if( folded_north )
then
2542 is2 = is; ie2 = ie; js2 = js; je2 = je
2543 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2545 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2548 if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0)
then
2549 if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2550 .AND. (position == corner .OR. position == north))
then
2551 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2552 isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2554 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2555 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, symmetry=domain%symmetry)
2558 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2559 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2561 if(ie2 .GE. is2)
then
2562 if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2563 .AND. (position == corner .OR. position == north))
then
2564 call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2565 isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2567 call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2568 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, symmetry=domain%symmetry)
2574 if(is .LT. isg .AND. domain%x(tme)%cyclic)
then
2584 if( folded_north .AND. (position == north .OR. position == corner) &
2585 .AND. domain%x(tme)%pos .GE.
size(domain%x(tme)%list(:))/2)
then
2586 if( jed .GE. jeg .AND. ied .GE. middle)
then
2587 jsd = jeg; jed = jeg
2588 is=isc; ie=iec; js = jsc; je = jec
2589 isd = max(isd, middle)
2590 select case (position)
2592 i=is; is = isg+ieg-ie; ie = isg+ieg-i
2594 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2596 call insert_update_overlap(overlap, domain%list(m)%pe, &
2597 is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
2599 if(debug_update_level .NE. no_check .AND. set_check)
then
2600 jsd = domain%y(tme)%compute%end+jshift; jed = jsd
2602 is = max(is, isd); ie = min(ie, ied)
2603 js = max(js, jsd); je = min(je, jed)
2604 if(ie.GE.is .AND. je.GE.js )
then
2605 nrecv_check = nrecv_check+1
2606 if(nrecv_check >
size(checklist(:)) )
then
2607 call expand_check_overlap_list(checklist, nlist)
2609 call allocate_check_overlap(checklist(nrecv_check), 1)
2610 call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
2611 tme, 4, one_hundred_eighty, is, ie, js, je)
2621 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2622 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2623 is=isc; ie=iec; js=jsc; je=jec
2624 is2 = 0; ie2=-1; js2=0; je2=-1
2625 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2626 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0)
then
2628 if( jsd .GT. jeg )
then
2629 if( domain%y(tme)%cyclic .AND. je.LT.jsd )
then
2630 js = js+joff; je = je+joff
2632 else if( folded_north )
then
2634 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2636 else if( jed.GT.jeg )
then
2637 if( domain%y(tme)%cyclic)
then
2638 is2 = is; ie2 = ie; js2 = js; je2 = je
2639 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2640 js = js + joff; je = je + joff
2642 else if( folded_north )
then
2644 is2 = is; ie2 = ie; js2 = js; je2 = je
2645 isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2647 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2648 if(ied > ieg .and. isd .LE. ieg .and. domain%symmetry)
then
2649 isd3 = ieg+1; ied3 = ied
2650 jsd3 = jsd; jed3 = jed
2651 is3 = is+ioff; ie3=ie+ioff
2657 if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2658 .AND. (position == corner .OR. position == north))
then
2659 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2660 isg, ieg, dir, ishift, position, ioff, middle)
2662 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2663 isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2665 if(ie3 .GE. is3)
call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2666 & jed3, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2667 if(ie2 .GE. is2)
then
2668 if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2669 .AND. (position == corner .OR. position == north))
then
2670 call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2671 isg, ieg, dir, ishift, position, ioff, middle)
2673 call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2674 isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2678 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2679 if( jed.GT.jeg )
then
2680 if( domain%y(tme)%cyclic .AND. je.LT.jsd )
then
2681 js = js+joff; je = je+joff
2682 need_adjust_1 = .false.
2683 if( ied.GT.ieg )
then
2684 if( domain%x(tme)%cyclic .AND. ie.LT.isd )
then
2685 is = is+ioff; ie = ie+ioff
2686 need_adjust_2 = .false.
2687 if(x_cyclic_offset .NE. 0)
then
2689 else if(y_cyclic_offset .NE. 0)
then
2695 need_adjust_3 = .false.
2697 else if( folded_north )
then
2699 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2702 if( need_adjust_3 .AND. ied.GT.ieg )
then
2703 if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. ie.LT.isd )
then
2704 is = is+ioff; ie = ie+ioff
2705 if( need_adjust_1 .AND. jed.LE.jeg)
then
2710 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2711 isg, ieg, jsg, jeg, dir)
2716 if( overlap%count > 0)
then
2718 if(nrecv >
size(overlaplist(:)) )
then
2719 call mpp_error(note,
'mpp_domains_define.inc(compute_overlaps): overlapList for recv is expanded')
2720 call expand_update_overlap_list(overlaplist, nlist)
2722 call add_update_overlap( overlaplist(nrecv), overlap)
2723 call init_overlap_type(overlap)
2727 if(debug_message_passing)
then
2731 write(iunit, *)
"********from_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
2732 do n = 1, overlaplist(m)%count
2733 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
2734 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
2737 if(nrecv >0)
flush(iunit)
2742 if (
associated(update%recv))
deallocate(update%recv)
2743 allocate(update%recv(nrecv))
2744 update%nrecv = nrecv
2746 call add_update_overlap( update%recv(m), overlaplist(m) )
2747 do n = 1, update%recv(m)%count
2748 if(update%recv(m)%tileNbr(n) == domain%tile_id(tme))
then
2749 if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
2750 if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
2756 if(nrecv_check>0)
then
2757 check%nrecv = nrecv_check
2758 if (
associated(check%recv))
deallocate(check%recv)
2759 allocate(check%recv(nrecv_check))
2760 do m = 1, nrecv_check
2765 call deallocate_overlap_type(overlap)
2766 do m = 1,
size(overlaplist(:))
2767 call deallocate_overlap_type(overlaplist(m))
2770 if(debug_update_level .NE. no_check .AND. set_check)
then
2771 do m = 1,
size(checklist(:))
2772 call deallocate_overlap_type(checklist(m))
2776 deallocate(overlaplist)
2777 if(set_check)
deallocate(checklist)
2778 domain%initialized = .true.
2783 subroutine fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2784 isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2785 type(overlap_type),
intent(inout) :: overlap
2786 type(domain2d),
intent(inout) :: domain
2787 integer,
intent(in ) :: m, is, ie, js, je
2788 integer,
intent(in ) :: isc, iec, jsc, jec
2789 integer,
intent(in ) :: isg, ieg, dir, ioff
2790 logical,
intent(in ) :: is_cyclic
2791 logical,
optional,
intent(in ) :: folded, symmetry
2793 call insert_update_overlap( overlap, domain%list(m)%pe, &
2794 is, ie, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2796 if(ie .GT. ieg)
then
2797 call insert_update_overlap( overlap, domain%list(m)%pe, &
2798 is-ioff, ie-ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2799 else if( is .LT. isg )
then
2800 call insert_update_overlap( overlap, domain%list(m)%pe, &
2801 is+ioff, ie+ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2805 end subroutine fill_overlap_send_nofold
2807 subroutine fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2808 isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2809 type(overlap_type),
intent(inout) :: overlap
2810 type(domain2d),
intent(inout) :: domain
2811 integer,
intent(in ) :: m, is, ie, js, je
2812 integer,
intent(in ) :: isc, iec, jsc, jec
2813 integer,
intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2814 logical,
optional,
intent(in ) :: symmetry
2815 integer :: is1, ie1, is2, ie2, i
2819 if(position == corner .AND. .NOT. domain%symmetry .AND. is .LE. isg-1 .AND. ie .GE. isg-1)
then
2820 call insert_update_overlap(overlap, domain%list(m)%pe, &
2821 isg-1+ioff, isg-1+ioff, je, je, isc, iec, jsc, jec, dir, .true.)
2824 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2827 is2 = is-ioff; ie2 = ie-ioff
2828 else if( ie > ieg )
then
2830 is2 = ieg+1-ioff; ie2 = ie-ioff
2831 else if( is .GE. middle )
then
2833 else if( ie .GE. middle )
then
2834 is1 = middle; ie1 = ie
2835 is2 = is; ie2 = middle-1
2836 else if( ie < isg )
then
2837 is1 = is+ieg-isg+1-ishift; ie1 = ie+ieg-isg+1-ishift
2838 else if( is < isg )
then
2839 is1 = is+ieg-isg+1-ishift; ie1 = isg-1+ieg-isg+1-ishift
2845 if( ie1 .GE. is1)
then
2846 call insert_update_overlap( overlap, domain%list(m)%pe, &
2847 is1, ie1, js, je-1, isc, iec, jsc, jec, dir, symmetry=symmetry)
2849 select case (position)
2851 i=is1; is1 = isg+ieg-ie1; ie1 = isg+ieg-i
2853 i=is1; is1 = isg+ieg-ie1-1+ishift; ie1 = isg+ieg-i-1+ishift
2855 call insert_update_overlap( overlap, domain%list(m)%pe, &
2856 is1, ie1, je, je, isc, iec, jsc, jec, dir, .true., symmetry=symmetry)
2859 if(ie2 .GE. is2)
then
2860 call insert_update_overlap( overlap, domain%list(m)%pe, &
2861 is2, ie2, js, je, isc, iec, jsc, jec, dir)
2864 end subroutine fill_overlap_send_fold
2868 subroutine fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2869 isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2870 type(overlap_type),
intent(inout) :: overlap
2871 type(domain2d),
intent(inout) :: domain
2872 integer,
intent(in ) :: m, is, ie, js, je
2873 integer,
intent(in ) :: isd, ied, jsd, jed
2874 integer,
intent(in ) :: isg, ieg, dir, ioff
2875 logical,
intent(in ) :: is_cyclic
2876 logical,
optional,
intent(in ) :: folded, symmetry
2877 integer :: is1, ie1, is2, ie2
2878 integer :: isd1, ied1, isd2, ied2
2880 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2884 call insert_update_overlap( overlap, domain%list(m)%pe, &
2885 is, ie, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2887 if(ied .GT. ieg)
then
2888 call insert_update_overlap( overlap, domain%list(m)%pe, &
2889 is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2890 else if( isd .LT. isg )
then
2891 call insert_update_overlap( overlap, domain%list(m)%pe, &
2892 is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2893 else if ( is .LT. isg )
then
2894 call insert_update_overlap( overlap, domain%list(m)%pe, &
2895 is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2896 else if ( ie .GT. ieg )
then
2897 call insert_update_overlap( overlap, domain%list(m)%pe, &
2898 is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2902 end subroutine fill_overlap_recv_nofold
2904 subroutine fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2905 isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2906 type(overlap_type),
intent(inout) :: overlap
2907 type(domain2d),
intent(inout) :: domain
2908 integer,
intent(in ) :: m, is, ie, js, je
2909 integer,
intent(in ) :: isd, ied, jsd, jed
2910 integer,
intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2911 logical,
optional,
intent(in ) :: symmetry
2912 integer :: is1, ie1, is2, ie2, is3, ie3
2913 integer :: isd1, ied1, isd2, ied2
2917 if( position == corner .AND. .NOT. domain%symmetry .AND. isd .LE. isg-1 .AND. ied .GE. isg-1 )
then
2918 call insert_update_overlap( overlap, domain%list(m)%pe, &
2919 is-ioff, ie-ioff, js, je, isg-1, isg-1, jed, jed, dir, .true.)
2922 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2925 select case (position)
2927 is3 = isg+ieg-ie; ie3 = isg+ieg-is
2929 is3 = isg+ieg-ie-1+ishift; ie3 = isg+ieg-is-1+ishift
2932 if(isd .GT. ieg)
then
2933 is2 = is + ioff; ie2 = ie + ioff;
2934 else if(ied .GT. ieg)
then
2936 isd1 = isd; ied1 = ieg;
2937 is2 = is + ioff; ie2 = ie + ioff
2938 isd2 = ieg + 1; ied2 = ied
2939 else if(isd .GE. middle)
then
2941 else if(ied .GE. middle)
then
2943 isd1 = middle; ied1 = ied
2945 isd2 = isd; ied2 = middle-1
2946 else if(ied .LT. isg)
then
2947 is1 = is - ioff; ie1 = ie - ioff;
2948 is3 = is3 - ioff; ie3 = ie3 - ioff;
2949 else if(isd .LT. isg)
then
2950 is1 = is - ioff; ie1 = ie - ioff;
2951 is3 = is3 - ioff; ie3 = ie3 - ioff;
2952 isd1 = isd; ied1 = isg-1
2954 isd2 = isg; ied2 = ied
2957 isd2 = isd; ied2 = ied
2960 if( ie1 .GE. is1)
then
2961 call insert_update_overlap( overlap, domain%list(m)%pe, &
2962 is1, ie1, js, je, isd1, ied1, jsd, jed-1, dir, symmetry=symmetry)
2964 call insert_update_overlap( overlap, domain%list(m)%pe, &
2965 is3, ie3, js, je, isd1, ied1, jed, jed, dir, .true., symmetry=symmetry)
2968 if(ie2 .GE. is2)
then
2969 call insert_update_overlap( overlap, domain%list(m)%pe, &
2970 is2, ie2, js, je, isd2, ied2, jsd, jed, dir)
2973 end subroutine fill_overlap_recv_fold
2976 subroutine fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2977 isg, ieg, jsg, jeg, dir, reverse, symmetry)
2978 type(overlap_type),
intent(inout) :: overlap
2979 type(domain2d),
intent(inout) :: domain
2980 integer,
intent(in ) :: m, is, ie, js, je
2981 integer,
intent(in ) :: isc, iec, jsc, jec
2982 integer,
intent(in ) :: isg, ieg, jsg, jeg
2983 integer,
intent(in ) :: dir
2984 logical,
optional,
intent(in ) :: reverse, symmetry
2988 call insert_update_overlap( overlap, domain%list(m)%pe, &
2989 is, ie, jsg, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2990 call insert_update_overlap( overlap, domain%list(m)%pe, &
2991 is, ie, js, jeg, isc, iec, jsc, jec, dir, reverse, symmetry)
2992 else if(is > ie)
then
2994 call insert_update_overlap( overlap, domain%list(m)%pe, &
2995 is, ieg, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2996 call insert_update_overlap( overlap, domain%list(m)%pe, &
2997 isg, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2999 call insert_update_overlap( overlap, domain%list(m)%pe, &
3000 is, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
3004 end subroutine fill_overlap
3011 type(domain2d),
intent(inout) :: domain
3012 integer,
intent(in) :: position, ishift, jshift
3014 integer :: i, m, n, nlist, tMe, tNbr, dir
3015 integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3016 integer :: isg, ieg, jsg, jeg, ioff, joff
3017 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3018 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3020 type(overlap_type) :: overlap
3021 type(overlapspec),
pointer :: update=>null()
3022 type(overlap_type),
pointer :: overlapList(:)=>null()
3023 type(overlap_type),
pointer :: checkList(:)=>null()
3024 type(overlapspec),
pointer :: check =>null()
3025 integer :: nsend, nrecv
3026 integer :: nsend_check, nrecv_check
3032 if(
size(domain%x(:)) > 1)
return
3035 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0)
return
3038 nlist =
size(domain%list(:))
3040 select case(position)
3042 update => domain%update_T
3045 update => domain%update_C
3046 check => domain%check_C
3048 update => domain%update_E
3049 check => domain%check_E
3051 update => domain%update_N
3052 check => domain%check_N
3054 call mpp_error(fatal, &
3055 "mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, &
3059 allocate(overlaplist(maxlist) )
3060 allocate(checklist(maxlist) )
3063 call allocate_update_overlap( overlap, maxoverlap)
3066 call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3067 call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position )
3068 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3069 update%xbegin = ism; update%xend = iem
3070 update%ybegin = jsm; update%yend = jem
3071 if(
ASSOCIATED(check))
then
3072 check%xbegin = ism; check%xend = iem
3073 check%ybegin = jsm; check%yend = jem
3075 update%whalo = domain%whalo; update%ehalo = domain%ehalo
3076 update%shalo = domain%shalo; update%nhalo = domain%nhalo
3077 whalo = domain%whalo; ehalo = domain%ehalo
3078 shalo = domain%shalo; nhalo = domain%nhalo
3083 middle = (isg+ieg)/2+1
3086 if(.NOT. btest(domain%fold,south))
then
3087 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3088 "boundary condition in y-direction should be folded-south for "//trim(domain%name))
3090 if(.NOT. domain%x(tme)%cyclic)
then
3091 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3092 "boundary condition in x-direction should be cyclic for "//trim(domain%name))
3095 if(.not. domain%symmetry)
then
3096 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3097 "when south boundary is folded, the domain must be symmetry for "//trim(domain%name))
3103 m = mod( domain%pos+list, nlist )
3104 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
3107 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3108 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3110 if( (position == north .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) )
then
3113 if( ie.GT.ieg .AND. iec.LT.is )
then
3114 is = is-ioff; ie = ie-ioff
3118 if( js == jsg .AND. (position == corner .OR. position == north) &
3119 .AND. is .GE. middle .AND. domain%list(m)%x(tnbr)%compute%end+ehalo+jshift .LE. ieg )
then
3120 call insert_update_overlap( overlap, domain%list(m)%pe, &
3121 is, ie, js+1, je, isc, iec, jsc, jec, dir)
3122 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3124 select case (position)
3126 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3128 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3130 call insert_update_overlap( overlap, domain%list(m)%pe, &
3131 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3133 call insert_update_overlap( overlap, domain%list(m)%pe, &
3134 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3141 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3142 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3143 if( ie.GT.ieg .AND. iec.LT.is )
then
3144 is = is-ioff; ie = ie-ioff
3148 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3151 call insert_update_overlap( overlap, domain%list(m)%pe, &
3152 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3157 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3158 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3162 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3167 if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) )
then
3170 call insert_update_overlap( overlap, domain%list(m)%pe, &
3171 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3174 if(is .LT. isg)
then
3176 call insert_update_overlap( overlap, domain%list(m)%pe, &
3177 is, is, js, je, isc, iec, jsc, jec, dir, folded)
3183 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3184 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3185 if( isg.GT.is .AND. ie.LT.isc )
then
3186 is = is+ioff; ie = ie+ioff
3190 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3192 call insert_update_overlap( overlap, domain%list(m)%pe, &
3193 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3195 if(is .LT. isg)
then
3197 call insert_update_overlap( overlap, domain%list(m)%pe, &
3198 is, is, js, je, isc, iec, jsc, jec, dir, folded)
3203 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3204 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3207 if( (position == north .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) )
then
3210 if( isg.GT.is .AND. ie.LT.isc )
then
3211 is = is+ioff; ie = ie+ioff
3215 if( js == jsg .AND. (position == corner .OR. position == north) &
3216 .AND. ( domain%list(m)%x(tnbr)%compute%begin == isg .OR. &
3217 & domain%list(m)%x(tnbr)%compute%begin-1 .GE. middle))
then
3218 call insert_update_overlap( overlap, domain%list(m)%pe, &
3219 is, ie, js+1, je, isc, iec, jsc, jec, dir)
3220 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3221 js = domain%list(m)%y(tnbr)%compute%begin; je = js
3222 if ( domain%list(m)%x(tnbr)%compute%begin == isg )
then
3223 select case (position)
3225 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3227 i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3229 if(ie .GT. domain%x(tme)%compute%end+ishift)
call mpp_error( fatal, &
3230 'mpp_domains_define.inc(compute_overlaps_fold_south): west edge ubound error send.' )
3232 select case (position)
3234 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3236 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3239 call insert_update_overlap( overlap, domain%list(m)%pe, &
3240 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3242 call insert_update_overlap( overlap, domain%list(m)%pe, &
3243 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3249 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3250 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3251 if( isg.GT.is .AND. ie.LT.isc )
then
3252 is = is+ioff; ie = ie+ioff
3254 call insert_update_overlap( overlap, domain%list(m)%pe, &
3255 is, ie, js, je, isc, iec, jsc, jec, dir)
3259 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3260 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3261 call insert_update_overlap( overlap, domain%list(m)%pe, &
3262 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3266 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3267 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3268 if( ie.GT.ieg .AND. iec.LT.is )
then
3269 is = is-ioff; ie = ie-ioff
3271 call insert_update_overlap( overlap, domain%list(m)%pe, &
3272 is, ie, js, je, isc, iec, jsc, jec, dir)
3276 if( ( position == north .OR. position == corner) )
then
3278 if( domain%y(tme)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tme)%domain_data%end+jshift )
then
3281 if( domain%x(tme)%pos .LT. (
size(domain%x(tme)%list(:))+1)/2 )
then
3282 js = domain%list(m)%y(tnbr)%compute%begin; je = js
3284 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3285 select case (position)
3287 is = max(is, middle)
3288 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3290 is = max(is, middle)
3291 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3293 call insert_update_overlap(overlap, domain%list(m)%pe, &
3294 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3295 is = max(is, isc); ie = min(ie, iec)
3296 js = max(js, jsc); je = min(je, jec)
3297 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
3298 nsend_check = nsend_check+1
3299 call allocate_check_overlap(checklist(nsend_check), 1)
3300 call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
3301 tme, 2, one_hundred_eighty, is, ie, js, je)
3309 if( overlap%count > 0)
then
3311 if(nsend >
size(overlaplist(:)) )
then
3312 call mpp_error(note,
'mpp_domains_define.inc(compute_overlaps_south): overlapList for send is expanded')
3313 call expand_update_overlap_list(overlaplist, nlist)
3315 call add_update_overlap(overlaplist(nsend), overlap)
3316 call init_overlap_type(overlap)
3320 if(debug_message_passing)
then
3324 write(iunit, *)
"********to_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
3325 do n = 1, overlaplist(m)%count
3326 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3327 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3330 if( nsend > 0)
flush(iunit)
3335 if (
associated(update%send))
deallocate(update%send)
3336 allocate(update%send(nsend))
3337 update%nsend = nsend
3339 call add_update_overlap( update%send(m), overlaplist(m) )
3343 if(nsend_check>0)
then
3344 if (
associated(check%send))
deallocate(check%send)
3345 allocate(check%send(nsend_check))
3346 check%nsend = nsend_check
3347 do m = 1, nsend_check
3352 do m = 1,
size(overlaplist(:))
3353 call deallocate_overlap_type(overlaplist(m))
3356 if(debug_update_level .NE. no_check)
then
3357 do m = 1,
size(checklist(:))
3358 call deallocate_overlap_type(checklist(m))
3362 isgd = isg - domain%whalo
3363 iegd = ieg + domain%ehalo
3364 jsgd = jsg - domain%shalo
3365 jegd = jeg + domain%nhalo
3371 m = mod( domain%pos+nlist-list, nlist )
3372 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
3373 isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3374 jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3377 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3378 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
3379 is=isc; ie=iec; js=jsc; je=jec
3380 if( (position == north .OR. position == corner ) .AND. ( jsd == je .or. jed == js ) )
then
3383 if( ied.GT.ieg .AND. ie.LT.isd )
then
3384 is = is+ioff; ie = ie+ioff
3389 if( jsd == jsg .AND. (position == corner .OR. position == north) &
3390 .AND. isd .GE. middle .AND. ied .LE. ieg )
then
3391 call insert_update_overlap( overlap, domain%list(m)%pe, &
3392 is, ie, js, je, isd, ied, jsd+1, jed, dir)
3393 is=isc; ie=iec; js=jsc; je=jec
3395 select case (position)
3397 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3399 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3401 call insert_update_overlap( overlap, domain%list(m)%pe, &
3402 is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
3404 call insert_update_overlap( overlap, domain%list(m)%pe, &
3405 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3412 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3413 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3414 is=isc; ie=iec; js=jsc; je=jec
3415 if( jsd.LT.jsg )
then
3417 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3419 if( ied.GT.ieg .AND. ie.LT.isd )
then
3420 is = is+ioff; ie = ie+ioff
3422 call insert_update_overlap(overlap, domain%list(m)%pe, &
3423 is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3428 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3429 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3430 is=isc; ie=iec; js=jsc; je=jec
3431 if( jsd.LT.jsg )
then
3433 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3435 if( (position == east .OR. position == corner ) .AND. (isd == ie .or. ied == is ) )
then
3438 call insert_update_overlap(overlap, domain%list(m)%pe, &
3439 is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
3442 if(is .LT. isg )
then
3444 call insert_update_overlap(overlap, domain%list(m)%pe, &
3445 is, is, js, je, isd, ied, jsd, jed, dir, folded)
3451 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3452 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3453 is=isc; ie=iec; js=jsc; je=jec
3454 if( jsd.LT.jsg )
then
3456 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3458 if( isd.LT.isg .AND. is.GT.ied )
then
3459 is = is-ioff; ie = ie-ioff
3461 call insert_update_overlap(overlap, domain%list(m)%pe, &
3462 is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3464 if(is .LT. isg )
then
3466 call insert_update_overlap(overlap, domain%list(m)%pe, &
3467 is, is, js, je, isd, ied, jsd, jed, dir, folded )
3472 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3473 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
3474 is=isc; ie=iec; js=jsc; je=jec
3475 if( (position == north .OR. position == corner ) .AND. ( jsd == je .or. jed == js ) )
then
3478 if( isd.LT.isg .AND. is.GT.ied )
then
3479 is = is-ioff; ie = ie-ioff
3483 if( jsd == jsg .AND. (position == corner .OR. position == north) &
3484 .AND. ( isd < isg .OR. ied .GE. middle ) )
then
3485 call insert_update_overlap(overlap, domain%list(m)%pe, &
3486 is, ie, js, je, isd, ied, jsd+1, jed, dir)
3487 is=isc; ie=iec; js=jsc; je=jec
3489 select case (position)
3491 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3493 ied = ied -1 + ishift
3494 i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3496 if(ie .GT. domain%x(tme)%compute%end+ishift)
call mpp_error( fatal, &
3497 'mpp_domains_define.inc(compute_overlaps): west edge ubound error recv.' )
3499 select case (position)
3501 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3503 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3506 call insert_update_overlap(overlap, domain%list(m)%pe, &
3507 is, ie, js, je, isd, ied, jsd, jsd, dir, .true.)
3509 call insert_update_overlap(overlap, domain%list(m)%pe, &
3510 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3516 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3517 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3518 is=isc; ie=iec; js=jsc; je=jec
3519 if( isd.LT.isg .AND. is.GE.ied )
then
3520 is = is-ioff; ie = ie-ioff
3523 call insert_update_overlap( overlap, domain%list(m)%pe, &
3524 is, ie, js, je, isd, ied, jsd, jed, dir)
3528 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3529 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3530 is=isc; ie=iec; js=jsc; je=jec
3531 call insert_update_overlap( overlap, domain%list(m)%pe, &
3532 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3536 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3537 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3538 is=isc; ie=iec; js=jsc; je=jec
3539 if( ied.GT.ieg .AND. ie.LT.isd )
then
3540 is = is+ioff; ie = ie+ioff
3542 call insert_update_overlap( overlap, domain%list(m)%pe, &
3543 is, ie, js, je, isd, ied, jsd, jed, dir)
3548 if( ( position == north .OR. position == corner) )
then
3550 if( domain%y(tme)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tme)%domain_data%end+jshift )
then
3553 if( domain%x(tme)%pos .GE.
size(domain%x(tme)%list(:))/2 )
then
3554 jsd = domain%y(tme)%compute%begin; jed = jsd
3555 if( jsd == jsg )
then
3556 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3557 is=isc; ie=iec; js = jsc; je = jec
3558 select case (position)
3560 isd = max(isd, middle)
3561 i=is; is = isg+ieg-ie; ie = isg+ieg-i
3563 isd = max(isd, middle)
3564 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3566 call insert_update_overlap(overlap, domain%list(m)%pe, &
3567 is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
3568 is = max(is, isd); ie = min(ie, ied)
3569 js = max(js, jsd); je = min(je, jed)
3570 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
3571 nrecv_check = nrecv_check+1
3572 call allocate_check_overlap(checklist(nrecv_check), 1)
3573 call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
3574 tme, 2, one_hundred_eighty, is, ie, js, je)
3582 if( overlap%count > 0)
then
3584 if(nrecv >
size(overlaplist(:)) )
then
3585 call mpp_error(note,
'mpp_domains_define.inc(compute_overlaps_south): overlapList for recv is expanded')
3586 call expand_update_overlap_list(overlaplist, nlist)
3588 call add_update_overlap( overlaplist(nrecv), overlap)
3589 call init_overlap_type(overlap)
3593 if(debug_message_passing)
then
3597 write(iunit, *)
"********from_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
3598 do n = 1, overlaplist(m)%count
3599 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3600 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3603 if(nrecv >0)
flush(iunit)
3608 update%nrecv = nrecv
3609 if (
associated(update%recv))
deallocate(update%recv)
3610 allocate(update%recv(nrecv))
3612 call add_update_overlap( update%recv(m), overlaplist(m) )
3613 do n = 1, update%recv(m)%count
3614 if(update%recv(m)%tileNbr(n) == domain%tile_id(tme))
then
3615 if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
3616 if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
3622 if(nrecv_check>0)
then
3623 check%nrecv = nrecv_check
3624 if (
associated(check%recv))
deallocate(check%recv)
3625 allocate(check%recv(nrecv_check))
3626 do m = 1, nrecv_check
3631 call deallocate_overlap_type(overlap)
3633 do m = 1,
size(overlaplist(:))
3634 call deallocate_overlap_type(overlaplist(m))
3637 if(debug_update_level .NE. no_check)
then
3638 do m = 1,
size(checklist(:))
3639 call deallocate_overlap_type(checklist(m))
3643 deallocate(overlaplist)
3644 deallocate(checklist)
3647 domain%initialized = .true.
3656 type(domain2d),
intent(inout) :: domain
3657 integer,
intent(in) :: position, ishift, jshift
3659 integer :: j, m, n, nlist, tMe, tNbr, dir
3660 integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3661 integer :: isg, ieg, jsg, jeg, ioff, joff
3662 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3663 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3665 type(overlap_type) :: overlap
3666 type(overlapspec),
pointer :: update=>null()
3667 type(overlap_type) :: overlapList(MAXLIST)
3668 type(overlap_type) :: checkList(MAXLIST)
3669 type(overlapspec),
pointer :: check =>null()
3670 integer :: nsend, nrecv
3671 integer :: nsend_check, nrecv_check
3677 if(
size(domain%x(:)) > 1)
return
3680 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0)
return
3683 nlist =
size(domain%list(:))
3685 select case(position)
3687 update => domain%update_T
3690 update => domain%update_C
3691 check => domain%check_C
3693 update => domain%update_E
3694 check => domain%check_E
3696 update => domain%update_N
3697 check => domain%check_N
3699 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_west):"//&
3700 &
" the value of position should be CENTER, EAST, CORNER or NORTH")
3704 call allocate_update_overlap( overlap, maxoverlap)
3707 call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3708 call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position )
3709 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3710 update%xbegin = ism; update%xend = iem
3711 update%ybegin = jsm; update%yend = jem
3712 if(
ASSOCIATED(check))
then
3713 check%xbegin = ism; check%xend = iem
3714 check%ybegin = jsm; check%yend = jem
3716 update%whalo = domain%whalo; update%ehalo = domain%ehalo
3717 update%shalo = domain%shalo; update%nhalo = domain%nhalo
3718 whalo = domain%whalo; ehalo = domain%ehalo
3719 shalo = domain%shalo; nhalo = domain%nhalo
3723 middle = (jsg+jeg)/2+1
3726 if(.NOT. btest(domain%fold,west))
then
3727 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3728 "boundary condition in y-direction should be folded-west for "//trim(domain%name))
3730 if(.NOT. domain%y(tme)%cyclic)
then
3731 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3732 "boundary condition in y-direction should be cyclic for "//trim(domain%name))
3735 if(.not. domain%symmetry)
then
3736 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3737 "when west boundary is folded, the domain must be symmetry for "//trim(domain%name))
3743 m = mod( domain%pos+list, nlist )
3744 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
3747 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3748 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3749 call insert_update_overlap( overlap, domain%list(m)%pe, &
3750 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3754 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3755 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3756 if( js.LT.jsg .AND. jsc.GT.je )
then
3757 js = js+joff; je = je+joff
3760 call insert_update_overlap( overlap, domain%list(m)%pe, &
3761 is, ie, js, je, isc, iec, jsc, jec, dir)
3765 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3766 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3768 if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) )
then
3771 if( js.LT.jsg .AND. jsc.GT.je)
then
3772 js = js+joff; je = je+joff
3777 if( is == isg .AND. (position == corner .OR. position == east) &
3778 .AND. ( domain%list(m)%y(tnbr)%compute%begin == jsg .OR. &
3779 & domain%list(m)%y(tnbr)%compute%begin-1 .GE. middle))
then
3780 call insert_update_overlap( overlap, domain%list(m)%pe, &
3781 is+1, ie, js, je, isc, iec, jsc, jec, dir)
3782 is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3783 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3784 if ( domain%list(m)%y(tnbr)%compute%begin == jsg )
then
3785 select case (position)
3787 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
3789 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
3791 if(je .GT. domain%y(tme)%compute%end+jshift)
call mpp_error( fatal, &
3792 'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error send.' )
3794 select case (position)
3796 j=js; js = jsg+jeg-je; je = jsg+jeg-j
3798 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3801 call insert_update_overlap( overlap, domain%list(m)%pe, &
3802 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3804 call insert_update_overlap( overlap, domain%list(m)%pe, &
3805 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3812 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3813 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3814 if( jsg.GT.js .AND. je.LT.jsc )
then
3815 js = js+joff; je = je+joff
3819 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3821 call insert_update_overlap( overlap, domain%list(m)%pe, &
3822 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3824 if(js .LT. jsg)
then
3826 call insert_update_overlap( overlap, domain%list(m)%pe, &
3827 is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3833 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3834 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3837 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3842 if( (position == east .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) )
then
3845 call insert_update_overlap( overlap, domain%list(m)%pe, &
3846 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3849 if(js .LT. jsg)
then
3851 call insert_update_overlap( overlap, domain%list(m)%pe, &
3852 is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3858 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3859 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3860 if( je.GT.jeg .AND. jec.LT.js )
then
3861 js = js-joff; je = je-joff
3865 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3868 call insert_update_overlap( overlap, domain%list(m)%pe, &
3869 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3873 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3874 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3876 if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) )
then
3879 if( je.GT.jeg .AND. jec.LT.js)
then
3880 js = js-joff; je = je-joff
3884 if( is == isg .AND. (position == corner .OR. position == east) &
3885 .AND. ( js .GE. middle .AND. domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .LE. jeg ) )
then
3886 call insert_update_overlap( overlap, domain%list(m)%pe, &
3887 is+1, ie, js, je, isc, iec, jsc, jec, dir)
3888 is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3889 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3890 select case (position)
3892 j=js; js = jsg+jeg-je; je = jsg+jeg-j
3894 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3896 call insert_update_overlap( overlap, domain%list(m)%pe, &
3897 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3899 call insert_update_overlap( overlap, domain%list(m)%pe, &
3900 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3906 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3907 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3908 if( je.GT.jeg .AND. jec.LT.js )
then
3909 js = js-joff; je = je-joff
3911 call insert_update_overlap( overlap, domain%list(m)%pe, &
3912 is, ie, js, je, isc, iec, jsc, jec, dir)
3916 if( ( position == east .OR. position == corner) )
then
3918 if( domain%x(tme)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tme)%domain_data%end+ishift )
then
3921 if( domain%y(tme)%pos .LT. (
size(domain%y(tme)%list(:))+1)/2 )
then
3922 is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3924 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3925 select case (position)
3927 js = max(js, middle)
3928 j=js; js = jsg+jeg-je; je = jsg+jeg-j
3930 js = max(js, middle)
3931 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3933 call insert_update_overlap(overlap, domain%list(m)%pe, &
3934 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3935 is = max(is, isc); ie = min(ie, iec)
3936 js = max(js, jsc); je = min(je, jec)
3937 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
3938 nsend_check = nsend_check+1
3939 call allocate_check_overlap(checklist(nsend_check), 1)
3940 call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
3941 tme, 3, one_hundred_eighty, is, ie, js, je)
3949 if( overlap%count > 0)
then
3951 if(nsend > maxlist)
call mpp_error(fatal, &
3952 "mpp_domains_define.inc(compute_overlaps_west): nsend is greater than MAXLIST, increase MAXLIST")
3953 call add_update_overlap(overlaplist(nsend), overlap)
3954 call init_overlap_type(overlap)
3958 if(debug_message_passing)
then
3962 write(iunit, *)
"********to_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
3963 do n = 1, overlaplist(m)%count
3964 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3965 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3968 if(nsend >0)
flush(iunit)
3973 update%nsend = nsend
3974 if (
associated(update%send))
deallocate(update%send)
3975 allocate(update%send(nsend))
3977 call add_update_overlap( update%send(m), overlaplist(m) )
3981 if(nsend_check>0)
then
3982 check%nsend = nsend_check
3983 if (
associated(check%send))
deallocate(check%send)
3984 allocate(check%send(nsend_check))
3985 do m = 1, nsend_check
3991 call deallocate_overlap_type(overlaplist(m))
3992 if(debug_update_level .NE. no_check)
call deallocate_overlap_type(checklist(m))
3995 isgd = isg - domain%whalo
3996 iegd = ieg + domain%ehalo
3997 jsgd = jsg - domain%shalo
3998 jegd = jeg + domain%nhalo
4004 m = mod( domain%pos+nlist-list, nlist )
4005 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
4006 isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4007 jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4010 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4011 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4012 is=isc; ie=iec; js=jsc; je=jec
4013 call insert_update_overlap( overlap, domain%list(m)%pe, &
4014 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4018 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4019 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4020 is=isc; ie=iec; js=jsc; je=jec
4021 if( jsd.LT.jsg .AND. js.GE.jed )
then
4022 js = js-joff; je = je-joff
4024 call insert_update_overlap(overlap, domain%list(m)%pe, &
4025 is, ie, js, je, isd, ied, jsd, jed, dir)
4030 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4031 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4032 is=isc; ie=iec; js=jsc; je=jec
4034 if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) )
then
4037 if( jsd.LT.jsg .AND. js .GT. jed)
then
4038 js = js-joff; je = je-joff
4042 if( isd == isg .AND. (position == corner .OR. position == east) &
4043 .AND. ( jsd < jsg .OR. jed .GE. middle ) )
then
4044 call insert_update_overlap( overlap, domain%list(m)%pe, &
4045 is, ie, js, je, isd+1, ied, jsd, jed, dir)
4046 is=isc; ie=iec; js=jsc; je=jec
4048 select case (position)
4050 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4052 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4054 if(je .GT. domain%y(tme)%compute%end+jshift)
call mpp_error( fatal, &
4055 'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4057 select case (position)
4059 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4061 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4064 call insert_update_overlap( overlap, domain%list(m)%pe, &
4065 is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4067 call insert_update_overlap( overlap, domain%list(m)%pe, &
4068 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4075 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4076 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4077 is=isc; ie=iec; js=jsc; je=jec
4078 if( isd.LT.isg )
then
4080 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4082 if( jsd.LT.jsg .AND. js.GT.jed )
then
4083 js = js-joff; je = je-joff
4085 call insert_update_overlap(overlap, domain%list(m)%pe, &
4086 is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4088 if(js .LT. jsg )
then
4090 call insert_update_overlap(overlap, domain%list(m)%pe, &
4091 is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4097 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4098 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4099 is=isc; ie=iec; js=jsc; je=jec
4100 if( isd.LT.isg )
then
4102 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4104 if( (position == east .OR. position == corner ) .AND. (jsd == je .or. jed == js ) )
then
4107 call insert_update_overlap(overlap, domain%list(m)%pe, &
4108 is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4111 if(js .LT. jsg )
then
4113 call insert_update_overlap(overlap, domain%list(m)%pe, &
4114 is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4120 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4121 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4122 is=isc; ie=iec; js=jsc; je=jec
4123 if( isd.LT.isg)
then
4125 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4127 if( jed.GT.jeg .AND. je.LT.jsd )
then
4128 js = js+joff; je = je+joff
4131 call insert_update_overlap( overlap, domain%list(m)%pe, &
4132 is, ie, js, je, isd, ied, jsd, jed, dir)
4137 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4138 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4139 is=isc; ie=iec; js=jsc; je=jec
4140 if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) )
then
4143 if( jed.GT.jeg .AND. je.LT.jsd)
then
4144 js = js+joff; je = je+joff
4148 if( isd == isg .AND. (position == corner .OR. position == east) &
4149 .AND. jsd .GE. middle .AND. jed .LE. jeg )
then
4150 call insert_update_overlap( overlap, domain%list(m)%pe, &
4151 is, ie, js, je, isd+1, ied, jsd, jed, dir)
4152 is=isc; ie=iec; js=jsc; je=jec
4153 select case (position)
4155 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4157 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4159 call insert_update_overlap( overlap, domain%list(m)%pe, &
4160 is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4162 call insert_update_overlap( overlap, domain%list(m)%pe, &
4163 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4169 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4170 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4171 is=isc; ie=iec; js=jsc; je=jec
4172 if( jed.GT.jeg .AND. je.LT.jsd )
then
4173 js = js+joff; je = je+joff
4175 call insert_update_overlap( overlap, domain%list(m)%pe, &
4176 is, ie, js, je, isd, ied, jsd, jed, dir)
4181 if( ( position == east .OR. position == corner) )
then
4183 if( domain%x(tme)%domain_data%begin .LE. isg .AND. isg .LE. domain%x(tme)%domain_data%end+ishift )
then
4186 if( domain%y(tme)%pos .GE.
size(domain%y(tme)%list(:))/2 )
then
4187 isd = domain%x(tme)%compute%begin; ied = isd
4188 if( isd == isg )
then
4189 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4190 is=isc; ie=iec; js = jsc; je = jec
4191 select case (position)
4193 jsd = max(jsd, middle)
4194 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4196 jsd = max(jsd, middle)
4197 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4199 call insert_update_overlap(overlap, domain%list(m)%pe, &
4200 is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
4201 is = max(is, isd); ie = min(ie, ied)
4202 js = max(js, jsd); je = min(je, jed)
4203 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
4204 nrecv_check = nrecv_check+1
4205 call allocate_check_overlap(checklist(nrecv_check), 1)
4206 call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
4207 tme, 3, one_hundred_eighty, is, ie, js, je)
4215 if( overlap%count > 0)
then
4217 if(nrecv > maxlist)
call mpp_error(fatal, &
4218 "mpp_domains_define.inc(compute_overlaps_west): nrecv is greater than MAXLIST, increase MAXLIST")
4219 call add_update_overlap( overlaplist(nrecv), overlap)
4220 call init_overlap_type(overlap)
4224 if(debug_message_passing)
then
4228 write(iunit, *)
"********from_pe = " ,overlaplist(m)%pe,
" count = ",overlaplist(m)%count
4229 do n = 1, overlaplist(m)%count
4230 write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
4231 overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
4234 if(nrecv >0)
flush(iunit)
4239 update%nrecv = nrecv
4240 if (
associated(update%recv))
deallocate(update%recv)
4241 allocate(update%recv(nrecv))
4243 call add_update_overlap( update%recv(m), overlaplist(m) )
4244 do n = 1, update%recv(m)%count
4245 if(update%recv(m)%tileNbr(n) == domain%tile_id(tme))
then
4246 if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
4247 if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
4253 if(nrecv_check>0)
then
4254 check%nrecv = nrecv_check
4255 if (
associated(check%recv))
deallocate(check%recv)
4256 allocate(check%recv(nrecv_check))
4257 do m = 1, nrecv_check
4262 call deallocate_overlap_type(overlap)
4264 call deallocate_overlap_type(overlaplist(m))
4265 if(debug_update_level .NE. no_check)
call deallocate_overlap_type(checklist(m))
4270 domain%initialized = .true.
4280 type(domain2d),
intent(inout) :: domain
4281 integer,
intent(in) :: position, ishift, jshift
4283 integer :: j, m, n, nlist, tMe, tNbr, dir
4284 integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd
4285 integer :: jed, isg, ieg, jsg, jeg, ioff, joff
4286 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
4287 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
4289 type(overlap_type) :: overlap
4290 type(overlapspec),
pointer :: update=>null()
4291 type(overlap_type) :: overlapList(MAXLIST)
4292 type(overlap_type) :: checkList(MAXLIST)
4293 type(overlapspec),
pointer :: check =>null()
4294 integer :: nsend, nrecv
4295 integer :: nsend_check, nrecv_check
4300 if(
size(domain%x(:)) > 1)
return
4303 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0)
return
4306 nlist =
size(domain%list(:))
4308 select case(position)
4310 update => domain%update_T
4312 update => domain%update_C
4313 check => domain%check_C
4315 update => domain%update_E
4316 check => domain%check_E
4318 update => domain%update_N
4319 check => domain%check_N
4321 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_east):"// &
4322 &
" the value of position should be CENTER, EAST, CORNER or NORTH")
4326 call allocate_update_overlap( overlap, maxoverlap)
4329 call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
4330 call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position )
4331 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
4332 update%xbegin = ism; update%xend = iem
4333 update%ybegin = jsm; update%yend = jem
4334 if(
ASSOCIATED(check))
then
4335 check%xbegin = ism; check%xend = iem
4336 check%ybegin = jsm; check%yend = jem
4338 update%whalo = domain%whalo; update%ehalo = domain%ehalo
4339 update%shalo = domain%shalo; update%nhalo = domain%nhalo
4340 whalo = domain%whalo; ehalo = domain%ehalo
4341 shalo = domain%shalo; nhalo = domain%nhalo
4345 middle = (jsg+jeg)/2+1
4348 if(.NOT. btest(domain%fold,east))
then
4349 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4350 "boundary condition in y-direction should be folded-east for "//trim(domain%name))
4352 if(.NOT. domain%y(tme)%cyclic)
then
4353 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4354 "boundary condition in y-direction should be cyclic for "//trim(domain%name))
4356 if(.not. domain%symmetry)
then
4357 call mpp_error(fatal,
"mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4358 "when east boundary is folded, the domain must be symmetry for "//trim(domain%name))
4364 m = mod( domain%pos+list, nlist )
4365 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
4369 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
4370 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
4373 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4378 if( (position == east .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) )
then
4381 call insert_update_overlap( overlap, domain%list(m)%pe, &
4382 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
4385 if(js .LT. jsg)
then
4387 call insert_update_overlap( overlap, domain%list(m)%pe, &
4388 is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4394 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
4395 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4396 if( jsg.GT.js .AND. je.LT.jsc )
then
4397 js = js+joff; je = je+joff
4402 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4405 call insert_update_overlap( overlap, domain%list(m)%pe, &
4406 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4408 if(js .LT. jsg)
then
4410 call insert_update_overlap( overlap, domain%list(m)%pe, &
4411 is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4416 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
4417 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4419 if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) )
then
4422 if( js.LT.jsg .AND. jsc.GT.je)
then
4423 js = js+joff; je = je+joff
4427 if( ie == ieg .AND. (position == corner .OR. position == east) &
4428 .AND. ( domain%list(m)%y(tnbr)%compute%begin == jsg .OR. &
4429 domain%list(m)%y(tnbr)%compute%begin-1 .GE. middle ) )
then
4430 call insert_update_overlap( overlap, domain%list(m)%pe, &
4431 is, ie-1, js, je, isc, iec, jsc, jec, dir)
4434 if(position == corner .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tnbr)%compute%begin==jsg)
then
4435 call insert_update_overlap(overlap, domain%list(m)%pe, &
4436 ie, ie, je, je, isc, iec, jsc, jec, dir, .true.)
4439 ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4440 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4441 if ( domain%list(m)%y(tnbr)%compute%begin == jsg )
then
4442 select case (position)
4444 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4446 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4448 if(je .GT. domain%y(tme)%compute%end+jshift)
call mpp_error( fatal, &
4449 'mpp_domains_define.inc(compute_overlaps_fold_east: south edge ubound error send.' )
4451 select case (position)
4453 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4455 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4458 call insert_update_overlap( overlap, domain%list(m)%pe, &
4459 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4461 call insert_update_overlap( overlap, domain%list(m)%pe, &
4462 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4468 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4469 js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4470 if( js.LT.jsg .AND. jsc.GT.je )
then
4471 js = js+joff; je = je+joff
4473 call insert_update_overlap( overlap, domain%list(m)%pe, &
4474 is, ie, js, je, isc, iec, jsc, jec, dir)
4478 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4479 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
4480 call insert_update_overlap( overlap, domain%list(m)%pe, &
4481 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4485 is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4486 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4487 if( je.GT.jeg .AND. jec.LT.js )
then
4488 js = js-joff; je = je-joff
4490 call insert_update_overlap( overlap, domain%list(m)%pe, &
4491 is, ie, js, je, isc, iec, jsc, jec, dir)
4496 is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
4497 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4499 if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) )
then
4502 if( je.GT.jeg .AND. jec.LT.js)
then
4503 js = js-joff; je = je-joff
4507 if( ie == ieg .AND. (position == corner .OR. position == east) &
4508 .AND. ( js .GE. middle .AND. domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .LE. jeg ) )
then
4509 call insert_update_overlap( overlap, domain%list(m)%pe, &
4510 is, ie-1, js, je, isc, iec, jsc, jec, dir)
4511 ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4512 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4513 select case (position)
4515 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4517 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4519 call insert_update_overlap( overlap, domain%list(m)%pe, &
4520 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4522 call insert_update_overlap( overlap, domain%list(m)%pe, &
4523 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4530 is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
4531 js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4532 if( je.GT.jeg .AND. jec.LT.js )
then
4533 js = js-joff; je = je-joff
4537 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4540 call insert_update_overlap( overlap, domain%list(m)%pe, &
4541 is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4545 if( ( position == east .OR. position == corner) )
then
4547 if( domain%x(tme)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tme)%domain_data%end+ishift )
then
4550 if( domain%y(tme)%pos .LT. (
size(domain%y(tme)%list(:))+1)/2 )
then
4551 ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4553 js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
4554 select case (position)
4556 js = max(js, middle)
4557 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4559 js = max(js, middle)
4560 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4562 call insert_update_overlap(overlap, domain%list(m)%pe, &
4563 is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4564 is = max(is, isc); ie = min(ie, iec)
4565 js = max(js, jsc); je = min(je, jec)
4566 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
4567 nsend_check = nsend_check+1
4568 call allocate_check_overlap(checklist(nsend_check), 1)
4569 call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
4570 tme, 1, one_hundred_eighty, is, ie, js, je)
4578 if( overlap%count > 0)
then
4580 if(nsend > maxlist)
call mpp_error(fatal, &
4581 "mpp_domains_define.inc(compute_overlaps_east): nsend is greater than MAXLIST, increase MAXLIST")
4582 call add_update_overlap(overlaplist(nsend), overlap)
4583 call init_overlap_type(overlap)
4589 update%nsend = nsend
4590 if (
associated(update%send))
deallocate(update%send)
4591 allocate(update%send(nsend))
4593 call add_update_overlap( update%send(m), overlaplist(m) )
4597 if(nsend_check>0)
then
4598 check%nsend = nsend_check
4599 if (
associated(check%send))
deallocate(check%send)
4600 allocate(check%send(nsend_check))
4601 do m = 1, nsend_check
4607 call deallocate_overlap_type(overlaplist(m))
4608 if(debug_update_level .NE. no_check)
call deallocate_overlap_type(checklist(m))
4611 isgd = isg - domain%whalo
4612 iegd = ieg + domain%ehalo
4613 jsgd = jsg - domain%shalo
4614 jegd = jeg + domain%nhalo
4620 m = mod( domain%pos+nlist-list, nlist )
4621 if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) )
then
4622 isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4623 jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4627 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4628 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4629 is=isc; ie=iec; js=jsc; je=jec
4630 if( ied.GT.ieg )
then
4632 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4634 if( (position == east .OR. position == corner ) .AND. (jsd == je .or. jed == js ) )
then
4637 call insert_update_overlap(overlap, domain%list(m)%pe, &
4638 is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4641 if(js .LT. jsg )
then
4643 call insert_update_overlap(overlap, domain%list(m)%pe, &
4644 is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4650 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4651 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4652 is=isc; ie=iec; js=jsc; je=jec
4653 if( ied.GT.ieg )
then
4655 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4657 if( jsd.LT.jsg .AND. js.GT.jed )
then
4658 js = js-joff; je = je-joff
4660 call insert_update_overlap(overlap, domain%list(m)%pe, &
4661 is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4663 if(js .LT. jsg )
then
4665 call insert_update_overlap(overlap, domain%list(m)%pe, &
4666 is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4672 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4673 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4674 is=isc; ie=iec; js=jsc; je=jec
4676 if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) )
then
4679 if( jsd.LT.jsg .AND. js .GT. jed)
then
4680 js = js-joff; je = je-joff
4684 if( ied == ieg .AND. (position == corner .OR. position == east) &
4685 .AND. ( jsd < jsg .OR. jed .GE. middle ) )
then
4686 call insert_update_overlap( overlap, domain%list(m)%pe, &
4687 is, ie, js, je, isd, ied-1, jsd, jed, dir)
4688 is=isc; ie=iec; js=jsc; je=jec
4690 select case (position)
4692 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4694 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4696 if(je .GT. domain%y(tme)%compute%end+jshift)
call mpp_error( fatal, &
4697 'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4699 select case (position)
4701 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4703 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4706 call insert_update_overlap( overlap, domain%list(m)%pe, &
4707 is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4709 call insert_update_overlap( overlap, domain%list(m)%pe, &
4710 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4716 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4717 jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4718 is=isc; ie=iec; js=jsc; je=jec
4719 if( jsd.LT.jsg .AND. js.GE.jed )
then
4720 js = js-joff; je = je-joff
4722 call insert_update_overlap(overlap, domain%list(m)%pe, &
4723 is, ie, js, je, isd, ied, jsd, jed, dir)
4727 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4728 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4729 is=isc; ie=iec; js=jsc; je=jec
4730 call insert_update_overlap( overlap, domain%list(m)%pe, &
4731 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4736 isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4737 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4738 is=isc; ie=iec; js=jsc; je=jec
4739 if( jed.GT.jeg .AND. je.LT.jsd )
then
4740 js = js+joff; je = je+joff
4742 call insert_update_overlap( overlap, domain%list(m)%pe, &
4743 is, ie, js, je, isd, ied, jsd, jed, dir)
4748 isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4749 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4750 is=isc; ie=iec; js=jsc; je=jec
4751 if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) )
then
4754 if( jed.GT.jeg .AND. je.LT.jsd)
then
4755 js = js+joff; je = je+joff
4759 if( ied == ieg .AND. (position == corner .OR. position == east) &
4760 .AND. jsd .GE. middle .AND. jed .LE. jeg )
then
4761 call insert_update_overlap( overlap, domain%list(m)%pe, &
4762 is, ie, js, je, isd, ied-1, jsd, jed, dir)
4763 is=isc; ie=iec; js=jsc; je=jec
4764 select case (position)
4766 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4768 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4770 call insert_update_overlap( overlap, domain%list(m)%pe, &
4771 is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4773 call insert_update_overlap( overlap, domain%list(m)%pe, &
4774 is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4781 isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4782 jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4783 is=isc; ie=iec; js=jsc; je=jec
4784 if( ied.GT.ieg)
then
4786 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4788 if( jed.GT.jeg .AND. je.LT.jsd )
then
4789 js = js+joff; je = je+joff
4792 call insert_update_overlap( overlap, domain%list(m)%pe, &
4793 is, ie, js, je, isd, ied, jsd, jed, dir)
4797 if( ( position == east .OR. position == corner) )
then
4799 if( domain%x(tme)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tme)%domain_data%end+ishift )
then
4802 if( domain%y(tme)%pos .GE.
size(domain%y(tme)%list(:))/2 )
then
4803 ied = domain%x(tme)%compute%end+ishift; isd = ied
4804 if( ied == ieg )
then
4805 jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4806 is=isc; ie=iec; js = jsc; je = jec
4807 select case (position)
4809 jsd = max(jsd, middle)
4810 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4812 jsd = max(jsd, middle)
4813 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4815 call insert_update_overlap(overlap, domain%list(m)%pe, &
4816 is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
4817 is = max(is, isd); ie = min(ie, ied)
4818 js = max(js, jsd); je = min(je, jed)
4819 if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )
then
4820 nrecv_check = nrecv_check+1
4821 call allocate_check_overlap(checklist(nrecv_check), 1)
4822 call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
4823 tme, 3, one_hundred_eighty, is, ie, js, je)
4831 if( overlap%count > 0)
then
4833 if(nrecv > maxlist)
call mpp_error(fatal, &
4834 "mpp_domains_define.inc(compute_overlaps_east): nrecv is greater than MAXLIST, increase MAXLIST")
4835 call add_update_overlap( overlaplist(nrecv), overlap)
4836 call init_overlap_type(overlap)
4842 update%nrecv = nrecv
4843 if (
associated(update%recv))
deallocate(update%recv)
4844 allocate(update%recv(nrecv))
4846 call add_update_overlap( update%recv(m), overlaplist(m) )
4847 do n = 1, update%recv(m)%count
4848 if(update%recv(m)%tileNbr(n) == domain%tile_id(tme))
then
4849 if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
4850 if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
4856 if(nrecv_check>0)
then
4857 check%nrecv = nrecv_check
4858 if (
associated(check%recv))
deallocate(check%recv)
4859 allocate(check%recv(nrecv_check))
4860 do m = 1, nrecv_check
4865 call deallocate_overlap_type(overlap)
4867 call deallocate_overlap_type(overlaplist(m))
4868 if(debug_update_level .NE. no_check)
call deallocate_overlap_type(checklist(m))
4874 domain%initialized = .true.
4879 subroutine get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4880 integer,
intent(in) :: jsg, jeg, isg, jshift, position
4881 integer,
intent(inout) :: is, ie, js, je
4884 select case(position)
4886 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4887 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4889 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4890 i=is; is = 2*isg-ie; ie = 2*isg-i
4892 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4893 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4895 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4896 i=is; is = 2*isg-ie; ie = 2*isg-i
4899 end subroutine get_fold_index_west
4902 subroutine get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4903 integer,
intent(in) :: jsg, jeg, ieg, jshift, position
4904 integer,
intent(inout) :: is, ie, js, je
4907 select case(position)
4909 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4910 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4912 j=js; js = jsg+jeg-je; je = jsg+jeg-j
4913 i=is; is = 2*ieg-ie; ie = 2*ieg-i
4915 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4916 i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4918 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4919 i=is; is = 2*ieg-ie; ie = 2*ieg-i
4922 end subroutine get_fold_index_east
4925 subroutine get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
4926 integer,
intent(in) :: isg, ieg, jsg, ishift, position
4927 integer,
intent(inout) :: is, ie, js, je
4930 select case(position)
4932 i=is; is = isg+ieg-ie; ie = isg+ieg-i
4933 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4935 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4936 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4938 i=is; is = isg+ieg-ie; ie = isg+ieg-i
4939 j=js; js = 2*jsg-je; je = 2*jsg-j
4941 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4942 j=js; js = 2*jsg-je; je = 2*jsg-j
4945 end subroutine get_fold_index_south
4947 subroutine get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
4948 integer,
intent(in) :: isg, ieg, jeg, ishift, position
4949 integer,
intent(inout) :: is, ie, js, je
4952 select case(position)
4954 i=is; is = isg+ieg-ie; ie = isg+ieg-i
4955 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4957 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4958 j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4960 i=is; is = isg+ieg-ie; ie = isg+ieg-i
4961 j=js; js = 2*jeg-je; je = 2*jeg-j
4963 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4964 j=js; js = 2*jeg-je; je = 2*jeg-j
4967 end subroutine get_fold_index_north
4973 integer,
intent(inout) :: lstart, lend
4974 integer,
intent(in ) :: offset, gstart, gend, gsize
4976 lstart = lstart + offset
4977 if(lstart > gend) lstart = lstart - gsize
4978 if(lstart < gstart) lstart = lstart + gsize
4979 lend = lend + offset
4980 if(lend > gend) lend = lend - gsize
4981 if(lend < gstart) lend = lend + gsize
4994 subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
4995 type(domain2d),
intent(in) :: domain
4996 type(overlapspec),
intent(in) :: overlap_in
4997 type(overlapspec),
intent(inout) :: overlap_out
4998 integer,
intent(in) :: whalo_out, ehalo_out, shalo_out, nhalo_out
4999 integer :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation
5000 integer :: whalo_in, ehalo_in, shalo_in, nhalo_in
5002 type(overlap_type) :: overlap
5003 type(overlap_type),
allocatable :: send(:), recv(:)
5004 type(overlap_type),
pointer :: ptrIn => null()
5005 integer :: nsend, nrecv, nsend_in, nrecv_in
5007 if( domain%fold .NE. 0)
call mpp_error(fatal,
"mpp_domains_define.inc(set_overlaps):"// &
5008 &
" folded domain is not implemented for arbitrary halo update, contact developer")
5010 whalo_in = domain%whalo
5011 ehalo_in = domain%ehalo
5012 shalo_in = domain%shalo
5013 nhalo_in = domain%nhalo
5015 if( .NOT. domain%initialized)
call mpp_error(fatal, &
5016 "mpp_domains_define.inc: domain is not defined yet")
5018 nlist =
size(domain%list(:))
5019 isoff = whalo_in - abs(whalo_out)
5020 ieoff = ehalo_in - abs(ehalo_out)
5021 jsoff = shalo_in - abs(shalo_out)
5022 jeoff = nhalo_in - abs(nhalo_out)
5025 nsend_in = overlap_in%nsend
5026 nrecv_in = overlap_in%nrecv
5027 if(nsend_in>0)
allocate(send(nsend_in))
5028 if(nrecv_in>0)
allocate(recv(nrecv_in))
5029 call allocate_update_overlap(overlap, maxoverlap)
5031 overlap_out%whalo = whalo_out
5032 overlap_out%ehalo = ehalo_out
5033 overlap_out%shalo = shalo_out
5034 overlap_out%nhalo = nhalo_out
5035 overlap_out%xbegin = overlap_in%xbegin
5036 overlap_out%xend = overlap_in%xend
5037 overlap_out%ybegin = overlap_in%ybegin
5038 overlap_out%yend = overlap_in%yend
5042 ptrin => overlap_in%send(m)
5043 if(ptrin%count .LE. 0)
call mpp_error(fatal,
"mpp_domains_define.inc(set_overlaps):"// &
5044 " number of overlap for send should be a positive number for"//trim(domain%name) )
5045 do n = 1, ptrin%count
5047 rotation = ptrin%rotation(n)
5050 if(ehalo_out > 0)
then
5051 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, 0, n, dir, rotation)
5052 else if(ehalo_out<0)
then
5053 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, 0, n, dir, rotation)
5056 if(ehalo_out>0 .AND. shalo_out > 0)
then
5057 call set_single_overlap(ptrin, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation)
5058 else if(ehalo_out<0 .AND. shalo_out < 0)
then
5059 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation)
5060 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation)
5061 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation)
5064 if(shalo_out > 0)
then
5065 call set_single_overlap(ptrin, overlap, 0, 0, jsoff, 0, n, dir, rotation)
5066 else if(shalo_out<0)
then
5067 call set_single_overlap(ptrin, overlap, 0, 0, 0, shalo_out, n, dir, rotation)
5070 if(whalo_out>0 .AND. shalo_out > 0)
then
5071 call set_single_overlap(ptrin, overlap, isoff, 0, jsoff, 0, n, dir, rotation)
5072 else if(whalo_out<0 .AND. shalo_out < 0)
then
5073 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation)
5074 call set_single_overlap(ptrin, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation)
5075 call set_single_overlap(ptrin, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation)
5078 if(whalo_out > 0)
then
5079 call set_single_overlap(ptrin, overlap, isoff, 0, 0, 0, n, dir, rotation)
5080 else if(whalo_out<0)
then
5081 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, 0, n, dir, rotation)
5084 if(whalo_out>0 .AND. nhalo_out > 0)
then
5085 call set_single_overlap(ptrin, overlap, isoff, 0, 0, -jeoff, n, dir, rotation)
5086 else if(whalo_out<0 .AND. nhalo_out < 0)
then
5087 call set_single_overlap(ptrin, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation)
5088 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation)
5089 call set_single_overlap(ptrin, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation)
5092 if(nhalo_out > 0)
then
5093 call set_single_overlap(ptrin, overlap, 0, 0, 0, -jeoff, n, dir, rotation)
5094 else if(nhalo_out<0)
then
5095 call set_single_overlap(ptrin, overlap, 0, 0, -nhalo_out, 0, n, dir, rotation)
5098 if(ehalo_out>0 .AND. nhalo_out > 0)
then
5099 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation)
5100 else if(ehalo_out<0 .AND. nhalo_out < 0)
then
5101 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation)
5102 call set_single_overlap(ptrin, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation)
5103 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation)
5107 if(overlap%count>0)
then
5109 call add_update_overlap(send(nsend), overlap)
5110 call init_overlap_type(overlap)
5115 overlap_out%nsend = nsend
5116 if (
associated(overlap_out%send))
deallocate(overlap_out%send)
5117 allocate(overlap_out%send(nsend));
5119 call add_update_overlap(overlap_out%send(n), send(n) )
5122 overlap_out%nsend = 0
5131 ptrin => overlap_in%recv(m)
5132 if(ptrin%count .LE. 0)
call mpp_error(fatal, &
5133 "mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number")
5135 do n = 1, ptrin%count
5137 rotation = ptrin%rotation(n)
5140 if(ehalo_out > 0)
then
5141 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, 0, n, dir)
5142 else if(ehalo_out<0)
then
5143 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, 0, n, dir)
5146 if(ehalo_out>0 .AND. shalo_out > 0)
then
5147 call set_single_overlap(ptrin, overlap, 0, -ieoff, jsoff, 0, n, dir)
5148 else if(ehalo_out<0 .AND. shalo_out < 0)
then
5149 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, shalo_out, n, dir)
5150 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1)
5151 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, shalo_out, n, dir+1)
5154 if(shalo_out > 0)
then
5155 call set_single_overlap(ptrin, overlap, 0, 0, jsoff, 0, n, dir)
5156 else if(shalo_out<0)
then
5157 call set_single_overlap(ptrin, overlap, 0, 0, 0, shalo_out, n, dir)
5160 if(whalo_out>0 .AND. shalo_out > 0)
then
5161 call set_single_overlap(ptrin, overlap, isoff, 0, jsoff, 0, n, dir)
5162 else if(whalo_out<0 .AND. shalo_out < 0)
then
5163 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, shalo_out, n, dir)
5164 call set_single_overlap(ptrin, overlap, isoff, 0, 0, shalo_out, n, dir-1)
5165 call set_single_overlap(ptrin, overlap, 0, whalo_out, jsoff, 0, n, dir+1)
5168 if(whalo_out > 0)
then
5169 call set_single_overlap(ptrin, overlap, isoff, 0, 0, 0, n, dir)
5170 else if(whalo_out<0)
then
5171 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, 0, n, dir)
5174 if(whalo_out>0 .AND. nhalo_out > 0)
then
5175 call set_single_overlap(ptrin, overlap, isoff, 0, 0, -jeoff, n, dir)
5176 else if(whalo_out<0 .AND. nhalo_out < 0)
then
5177 call set_single_overlap(ptrin, overlap, 0, whalo_out, -nhalo_out, 0, n, dir)
5178 call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, -jeoff, n, dir-1)
5179 call set_single_overlap(ptrin, overlap, isoff, 0, -nhalo_out, 0, n, dir+1)
5182 if(nhalo_out > 0)
then
5183 call set_single_overlap(ptrin, overlap, 0, 0, 0, -jeoff, n, dir)
5184 else if(nhalo_out<0)
then
5185 call set_single_overlap(ptrin, overlap, 0, 0, -nhalo_out, 0, n, dir)
5188 if(ehalo_out>0 .AND. nhalo_out > 0)
then
5189 call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, -jeoff, n, dir)
5190 else if(ehalo_out<0 .AND. nhalo_out < 0)
then
5191 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir)
5192 call set_single_overlap(ptrin, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1)
5193 call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, -jeoff, n, 1)
5197 if(overlap%count>0)
then
5199 call add_update_overlap(recv(nrecv), overlap)
5200 call init_overlap_type(overlap)
5205 overlap_out%nrecv = nrecv
5206 if (
associated(overlap_out%recv))
deallocate(overlap_out%recv)
5207 allocate(overlap_out%recv(nrecv));
5209 call add_update_overlap(overlap_out%recv(n), recv(n) )
5212 overlap_out%nrecv = 0
5215 call deallocate_overlap_type(overlap)
5217 call deallocate_overlap_type(send(n))
5220 call deallocate_overlap_type(recv(n))
5222 if(
allocated(send))
deallocate(send)
5223 if(
allocated(recv))
deallocate(recv)
5226 call set_domain_comm_inf(overlap_out)
5232 subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation)
5233 type(overlap_type),
intent(in) :: overlap_in
5234 type(overlap_type),
intent(inout) :: overlap_out
5235 integer,
intent(in) :: isoff, jsoff, ieoff, jeoff
5236 integer,
intent(in) :: index
5237 integer,
intent(in) :: dir
5238 integer,
optional,
intent(in) :: rotation
5242 if( overlap_out%pe == null_pe )
then
5243 overlap_out%pe = overlap_in%pe
5245 if(overlap_out%pe .NE. overlap_in%pe)
call mpp_error(fatal, &
5246 "mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out")
5249 if(isoff .NE. 0 .and. ieoff .NE. 0)
call mpp_error(fatal, &
5250 "mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero")
5251 if(jsoff .NE. 0 .and. jeoff .NE. 0)
call mpp_error(fatal, &
5252 "mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero")
5255 overlap_out%count = overlap_out%count + 1
5256 count = overlap_out%count
5257 if(count > maxoverlap)
call mpp_error(fatal, &
5258 "set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
5260 if(
present(rotation)) rotate = rotation
5261 overlap_out%rotation (count) = overlap_in%rotation(index)
5262 overlap_out%dir (count) = dir
5263 overlap_out%tileMe (count) = overlap_in%tileMe(index)
5264 overlap_out%tileNbr (count) = overlap_in%tileNbr(index)
5268 overlap_out%is(count) = overlap_in%is(index) + isoff
5269 overlap_out%ie(count) = overlap_in%ie(index) + ieoff
5270 overlap_out%js(count) = overlap_in%js(index) + jsoff
5271 overlap_out%je(count) = overlap_in%je(index) + jeoff
5273 overlap_out%is(count) = overlap_in%is(index) - jeoff
5274 overlap_out%ie(count) = overlap_in%ie(index) - jsoff
5275 overlap_out%js(count) = overlap_in%js(index) + isoff
5276 overlap_out%je(count) = overlap_in%je(index) + ieoff
5278 overlap_out%is(count) = overlap_in%is(index) + jsoff
5279 overlap_out%ie(count) = overlap_in%ie(index) + jeoff
5280 overlap_out%js(count) = overlap_in%js(index) - ieoff
5281 overlap_out%je(count) = overlap_in%je(index) - isoff
5283 call mpp_error(fatal,
"mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY")
5286 end subroutine set_single_overlap
5291 refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5292 isgList, iegList, jsgList, jegList )
5293 type(domain2d),
intent(inout) :: domain
5294 integer,
intent(in) :: position
5295 integer,
intent(in) :: num_contact
5296 integer,
dimension(:),
intent(in) :: tile1, tile2
5297 integer,
dimension(:),
intent(in) :: align1, align2
5298 real,
dimension(:),
intent(in) :: refine1, refine2
5299 integer,
dimension(:),
intent(in) :: istart1, iend1
5300 integer,
dimension(:),
intent(in) :: jstart1, jend1
5301 integer,
dimension(:),
intent(in) :: istart2, iend2
5302 integer,
dimension(:),
intent(in) :: jstart2, jend2
5303 integer,
dimension(:),
intent(in) :: isgList, iegList
5304 integer,
dimension(:),
intent(in) :: jsgList, jegList
5306 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
5307 integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2
5308 integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2
5309 integer :: is, ie, js, je, ioff, joff
5310 integer :: ntiles, max_contact
5311 integer :: nlist, list, m, n, l, count, numS, numR
5312 integer :: whalo, ehalo, shalo, nhalo
5313 integer :: t1, t2, tt, pos
5314 integer :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir
5315 integer :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem
5316 integer :: dirlist(8)
5319 integer,
dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send
5320 integer,
dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send
5321 integer,
dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv
5322 integer,
dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv
5323 integer,
dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send
5324 real,
dimension(4*num_contact) :: refineRecv, refineSend
5325 integer,
dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
5326 integer :: nsend, nrecv, nsend2, nrecv2
5327 type(contact_type),
dimension(domain%ntiles) :: eCont, wCont, sCont, nCont
5328 type(overlap_type),
dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
5331 if( position .NE. center )
call mpp_error(fatal,
"mpp_domains_define.inc: " //&
5332 "routine define_contact_point can only be used to calculate overlapping for cell center.")
5334 ntiles = domain%ntiles
5336 econt(:)%ncontact = 0
5339 econt(n)%ncontact = 0; scont(n)%ncontact = 0; wcont(n)%ncontact = 0; ncont(n)%ncontact = 0;
5340 allocate(econt(n)%tile(num_contact), wcont(n)%tile(num_contact) )
5341 allocate(ncont(n)%tile(num_contact), scont(n)%tile(num_contact) )
5342 allocate(econt(n)%align1(num_contact), econt(n)%align2(num_contact) )
5343 allocate(wcont(n)%align1(num_contact), wcont(n)%align2(num_contact) )
5344 allocate(scont(n)%align1(num_contact), scont(n)%align2(num_contact) )
5345 allocate(ncont(n)%align1(num_contact), ncont(n)%align2(num_contact) )
5346 allocate(econt(n)%refine1(num_contact), econt(n)%refine2(num_contact) )
5347 allocate(wcont(n)%refine1(num_contact), wcont(n)%refine2(num_contact) )
5348 allocate(scont(n)%refine1(num_contact), scont(n)%refine2(num_contact) )
5349 allocate(ncont(n)%refine1(num_contact), ncont(n)%refine2(num_contact) )
5350 allocate(econt(n)%is1(num_contact), econt(n)%ie1(num_contact), econt(n)%js1(num_contact), &
5351 & econt(n)%je1(num_contact))
5352 allocate(econt(n)%is2(num_contact), econt(n)%ie2(num_contact), econt(n)%js2(num_contact), &
5353 & econt(n)%je2(num_contact))
5354 allocate(wcont(n)%is1(num_contact), wcont(n)%ie1(num_contact), wcont(n)%js1(num_contact), &
5355 & wcont(n)%je1(num_contact))
5356 allocate(wcont(n)%is2(num_contact), wcont(n)%ie2(num_contact), wcont(n)%js2(num_contact), &
5357 & wcont(n)%je2(num_contact))
5358 allocate(scont(n)%is1(num_contact), scont(n)%ie1(num_contact), scont(n)%js1(num_contact), &
5359 & scont(n)%je1(num_contact))
5360 allocate(scont(n)%is2(num_contact), scont(n)%ie2(num_contact), scont(n)%js2(num_contact), &
5361 & scont(n)%je2(num_contact))
5362 allocate(ncont(n)%is1(num_contact), ncont(n)%ie1(num_contact), ncont(n)%js1(num_contact), &
5363 & ncont(n)%je1(num_contact))
5364 allocate(ncont(n)%is2(num_contact), ncont(n)%ie2(num_contact), ncont(n)%js2(num_contact), &
5365 & ncont(n)%je2(num_contact))
5369 do n = 1, num_contact
5372 select case(align1(n))
5374 call fill_contact( econt(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5375 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5377 call fill_contact( wcont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5378 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5380 call fill_contact( scont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5381 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5383 call fill_contact( ncont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5384 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5386 select case(align2(n))
5388 call fill_contact( econt(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5389 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5391 call fill_contact( wcont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5392 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5394 call fill_contact( scont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5395 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5397 call fill_contact( ncont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5398 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5403 whalo = domain%whalo
5404 ehalo = domain%ehalo
5405 shalo = domain%shalo
5406 nhalo = domain%nhalo
5409 nlist =
size(domain%list(:))
5411 max_contact = 4*num_contact
5413 ntileme =
size(domain%x(:))
5414 refinesend = 1; refinerecv = 1
5420 do n = 1, domain%update_T%nsend
5421 pos = domain%update_T%send(n)%pe - mpp_root_pe()
5422 call add_update_overlap(overlapsend(pos), domain%update_T%send(n) )
5424 do n = 1, domain%update_T%nrecv
5425 pos = domain%update_T%recv(n)%pe - mpp_root_pe()
5426 call add_update_overlap(overlaprecv(pos), domain%update_T%recv(n) )
5429 call mpp_get_memory_domain(domain, ism, iem, jsm, jem)
5430 domain%update_T%xbegin = ism; domain%update_T%xend = iem
5431 domain%update_T%ybegin = jsm; domain%update_T%yend = jem
5432 domain%update_T%whalo = whalo; domain%update_T%ehalo = ehalo
5433 domain%update_T%shalo = shalo; domain%update_T%nhalo = nhalo
5436 tileme = domain%tile_id(tme)
5437 rotatesend = zero; rotaterecv = zero
5441 do n = 1, econt(tileme)%ncontact
5443 tilerecv(count) = econt(tileme)%tile(n); tilesend(count) = econt(tileme)%tile(n)
5444 align1recv(count) = econt(tileme)%align1(n); align2recv(count) = econt(tileme)%align2(n)
5445 align1send(count) = econt(tileme)%align1(n); align2send(count) = econt(tileme)%align2(n)
5446 refinesend(count) = econt(tileme)%refine2(n); refinerecv(count) = econt(tileme)%refine1(n)
5447 is1recv(count) = econt(tileme)%is1(n) + 1; ie1recv(count) = is1recv(count) + ehalo - 1
5448 js1recv(count) = econt(tileme)%js1(n); je1recv(count) = econt(tileme)%je1(n)
5449 select case(econt(tileme)%align2(n))
5451 is2recv(count) = econt(tileme)%is2(n); ie2recv(count) = is2recv(count) + ehalo - 1
5452 js2recv(count) = econt(tileme)%js2(n); je2recv(count) = econt(tileme)%je2(n)
5453 ie1send(count) = econt(tileme)%is1(n); is1send(count) = ie1send(count) - whalo + 1
5454 js1send(count) = econt(tileme)%js1(n); je1send(count) = econt(tileme)%je1(n)
5455 ie2send(count) = econt(tileme)%is2(n) - 1; is2send(count) = ie2send(count) - whalo + 1
5456 js2send(count) = econt(tileme)%js2(n); je2send(count) = econt(tileme)%je2(n)
5458 rotaterecv(count) = ninety; rotatesend(count) = minus_ninety
5459 js2recv(count) = econt(tileme)%js2(n); je2recv(count) = js2recv(count) + ehalo -1
5460 is2recv(count) = econt(tileme)%is2(n); ie2recv(count) = econt(tileme)%ie2(n)
5461 ie1send(count) = econt(tileme)%is1(n); is1send(count) = ie1send(count) - shalo + 1
5462 js1send(count) = econt(tileme)%js1(n); je1send(count) = econt(tileme)%je1(n)
5463 is2send(count) = econt(tileme)%is2(n); ie2send(count) = econt(tileme)%ie2(n)
5464 je2send(count) = econt(tileme)%js2(n) - 1; js2send(count) = je2send(count) - shalo + 1
5468 do n = 1, scont(tileme)%ncontact
5470 tilerecv(count) = scont(tileme)%tile(n); tilesend(count) = scont(tileme)%tile(n)
5471 align1recv(count) = scont(tileme)%align1(n); align2recv(count) = scont(tileme)%align2(n);
5472 align1send(count) = scont(tileme)%align1(n); align2send(count) = scont(tileme)%align2(n);
5473 refinesend(count) = scont(tileme)%refine2(n); refinerecv(count) = scont(tileme)%refine1(n)
5474 is1recv(count) = scont(tileme)%is1(n); ie1recv(count) = scont(tileme)%ie1(n)
5475 je1recv(count) = scont(tileme)%js1(n) - 1; js1recv(count) = je1recv(count) - shalo + 1
5476 select case(scont(tileme)%align2(n))
5478 is2recv(count) = scont(tileme)%is2(n); ie2recv(count) = scont(tileme)%ie2(n)
5479 je2recv(count) = scont(tileme)%je2(n); js2recv(count) = je2recv(count) - shalo + 1
5480 is1send(count) = scont(tileme)%is1(n); ie1send(count) = scont(tileme)%ie1(n)
5481 js1send(count) = scont(tileme)%js1(n); je1send(count) = js1send(count) + nhalo -1
5482 is2send(count) = scont(tileme)%is2(n); ie2send(count) = scont(tileme)%ie2(n)
5483 js2send(count) = scont(tileme)%je2(n)+1; je2send(count) = js2send(count) + nhalo - 1
5485 rotaterecv(count) = minus_ninety; rotatesend(count) = ninety
5486 ie2recv(count) = scont(tileme)%ie2(n); is2recv(count) = ie2recv(count) - shalo + 1
5487 js2recv(count) = scont(tileme)%js2(n); je2recv(count) = scont(tileme)%je2(n)
5488 is1send(count) = scont(tileme)%is1(n); ie1send(count) = scont(tileme)%ie1(n)
5489 js1send(count) = scont(tileme)%js1(n); je1send(count) = js1send(count) + ehalo - 1
5490 is2send(count) = scont(tileme)%ie2(n)+1; ie2send(count) = is2send(count) + ehalo - 1
5491 js2send(count) = scont(tileme)%js2(n); je2send(count) = scont(tileme)%je2(n)
5495 do n = 1, wcont(tileme)%ncontact
5497 tilerecv(count) = wcont(tileme)%tile(n); tilesend(count) = wcont(tileme)%tile(n)
5498 align1recv(count) = wcont(tileme)%align1(n); align2recv(count) = wcont(tileme)%align2(n);
5499 align1send(count) = wcont(tileme)%align1(n); align2send(count) = wcont(tileme)%align2(n);
5500 refinesend(count) = wcont(tileme)%refine2(n); refinerecv(count) = wcont(tileme)%refine1(n)
5501 ie1recv(count) = wcont(tileme)%is1(n) - 1; is1recv(count) = ie1recv(count) - whalo + 1
5502 js1recv(count) = wcont(tileme)%js1(n); je1recv(count) = wcont(tileme)%je1(n)
5503 select case(wcont(tileme)%align2(n))
5505 ie2recv(count) = wcont(tileme)%ie2(n); is2recv(count) = ie2recv(count) - whalo + 1
5506 js2recv(count) = wcont(tileme)%js2(n); je2recv(count) = wcont(tileme)%je2(n)
5507 is1send(count) = wcont(tileme)%is1(n); ie1send(count) = is1send(count) + ehalo - 1
5508 js1send(count) = wcont(tileme)%js1(n); je1send(count) = wcont(tileme)%je1(n)
5509 is2send(count) = wcont(tileme)%ie2(n)+1; ie2send(count) = is2send(count) + ehalo - 1
5510 js2send(count) = wcont(tileme)%js2(n); je2send(count) = wcont(tileme)%je2(n)
5512 rotaterecv(count) = ninety; rotatesend(count) = minus_ninety
5513 je2recv(count) = wcont(tileme)%je2(n); js2recv(count) = je2recv(count) - whalo + 1
5514 is2recv(count) = wcont(tileme)%is2(n); ie2recv(count) = wcont(tileme)%ie2(n)
5515 is1send(count) = wcont(tileme)%is1(n); ie1send(count) = is1send(count) + nhalo - 1
5516 js1send(count) = wcont(tileme)%js1(n); je1send(count) = wcont(tileme)%je1(n)
5517 js2send(count) = wcont(tileme)%je2(n)+1; je2send(count) = js2send(count) + nhalo - 1
5518 is2send(count) = wcont(tileme)%is2(n); ie2send(count) = wcont(tileme)%ie2(n)
5522 do n = 1, ncont(tileme)%ncontact
5524 tilerecv(count) = ncont(tileme)%tile(n); tilesend(count) = ncont(tileme)%tile(n)
5525 align1recv(count) = ncont(tileme)%align1(n); align2recv(count) = ncont(tileme)%align2(n);
5526 align1send(count) = ncont(tileme)%align1(n); align2send(count) = ncont(tileme)%align2(n);
5527 refinesend(count) = ncont(tileme)%refine2(n); refinerecv(count) = ncont(tileme)%refine1(n)
5528 is1recv(count) = ncont(tileme)%is1(n); ie1recv(count) = ncont(tileme)%ie1(n)
5529 js1recv(count) = ncont(tileme)%je1(n)+1; je1recv(count) = js1recv(count) + nhalo - 1
5530 select case(ncont(tileme)%align2(n))
5532 is2recv(count) = ncont(tileme)%is2(n); ie2recv(count) = ncont(tileme)%ie2(n)
5533 js2recv(count) = ncont(tileme)%js2(n); je2recv(count) = js2recv(count) + nhalo - 1
5534 is1send(count) = ncont(tileme)%is1(n); ie1send(count) = ncont(tileme)%ie1(n)
5535 je1send(count) = ncont(tileme)%je1(n); js1send(count) = je1send(count) - shalo + 1
5536 is2send(count) = ncont(tileme)%is2(n); ie2send(count) = ncont(tileme)%ie2(n)
5537 je2send(count) = ncont(tileme)%js2(n)-1; js2send(count) = je2send(count) - shalo + 1
5539 rotaterecv(count) = minus_ninety; rotatesend(count) = ninety
5540 is2recv(count) = ncont(tileme)%ie2(n); ie2recv(count) = is2recv(count) + nhalo - 1
5541 js2recv(count) = ncont(tileme)%js2(n); je2recv(count) = ncont(tileme)%je2(n)
5542 is1send(count) = ncont(tileme)%is1(n); ie1send(count) = ncont(tileme)%ie1(n)
5543 je1send(count) = ncont(tileme)%je1(n); js1send(count) = je1send(count) - whalo + 1
5544 ie2send(count) = ncont(tileme)%is2(n)-1; is2send(count) = ie2send(count) - whalo + 1
5545 js2send(count) = ncont(tileme)%js2(n); je2send(count) = ncont(tileme)%je2(n)
5554 if(.NOT. domain%rotated_ninety)
then
5555 call fill_corner_contact(econt, scont, wcont, ncont, isglist, ieglist, jsglist, jeglist, numr, nums, &
5556 tilerecv, tilesend, is1recv, ie1recv, js1recv, je1recv, is2recv, ie2recv, &
5557 js2recv, je2recv, is1send, ie1send, js1send, je1send, is2send, ie2send, &
5558 js2send, je2send, align1recv, align2recv, align1send, align2send, &
5559 whalo, ehalo, shalo, nhalo, tileme )
5562 isc = domain%x(tme)%compute%begin; iec = domain%x(tme)%compute%end
5563 jsc = domain%y(tme)%compute%begin; jec = domain%y(tme)%compute%end
5567 do list = 0, nlist-1
5568 m = mod( domain%pos+list, nlist )
5569 ntilenbr =
size(domain%list(m)%x(:))
5570 do tnbr = 1, ntilenbr
5571 if( domain%list(m)%tile_id(tnbr) .NE. tilesend(n) ) cycle
5572 isc1 = max(isc, is1send(n)); iec1 = min(iec, ie1send(n))
5573 jsc1 = max(jsc, js1send(n)); jec1 = min(jec, je1send(n))
5574 if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle
5580 if( align2send(n) .NE. east ) cycle
5581 isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5582 jsd = domain%list(m)%y(tnbr)%compute%begin; jed = domain%list(m)%y(tnbr)%compute%end
5584 isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5585 jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5587 if( align2send(n) .NE. south ) cycle
5588 isd = domain%list(m)%x(tnbr)%compute%begin; ied = domain%list(m)%x(tnbr)%compute%end
5589 jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5591 isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5592 jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5594 if( align2send(n) .NE. west ) cycle
5595 isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5596 jsd = domain%list(m)%y(tnbr)%compute%begin; jed = domain%list(m)%y(tnbr)%compute%end
5598 isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5599 jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5601 if( align2send(n) .NE. north ) cycle
5602 isd = domain%list(m)%x(tnbr)%compute%begin; ied = domain%list(m)%x(tnbr)%compute%end
5603 jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5605 isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5606 jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5608 isd = max(isd, is2send(n)); ied = min(ied, ie2send(n))
5609 jsd = max(jsd, js2send(n)); jed = min(jed, je2send(n))
5610 if( isd > ied .OR. jsd > jed ) cycle
5614 select case ( align2send(n) )
5616 ioff = isd - is2send(n)
5617 joff = jsd - js2send(n)
5618 case ( south, north )
5619 ioff = isd - is2send(n)
5620 joff = jsd - js2send(n)
5624 select case ( rotatesend(n) )
5626 isc2 = is1send(n) + ioff; iec2 = isc2 + nxd - 1
5627 jsc2 = js1send(n) + joff; jec2 = jsc2 + nyd - 1
5629 iec2 = ie1send(n) - joff; isc2 = iec2 - nyd + 1
5630 jsc2 = js1send(n) + ioff; jec2 = jsc2 + nxd - 1
5631 case ( minus_ninety )
5632 isc2 = is1send(n) + joff; iec2 = isc2 + nyd - 1
5633 jec2 = je1send(n) - ioff; jsc2 = jec2 - nxd + 1
5635 is = max(isc1,isc2); ie = min(iec1,iec2)
5636 js = max(jsc1,jsc2); je = min(jec1,jec2)
5637 if(ie.GE.is .AND. je.GE.js )
then
5638 if(.not.
associated(overlapsend(m)%tileMe))
call allocate_update_overlap(overlapsend(m), &
5640 call insert_overlap_type(overlapsend(m), domain%list(m)%pe, tme, tnbr, &
5641 is, ie, js, je, dir, rotatesend(n), .true. )
5650 do list = 0, nlist-1
5651 m = mod( domain%pos+nlist-list, nlist )
5652 ntilenbr =
size(domain%list(m)%x(:))
5653 do tnbr = 1, ntilenbr
5654 if( domain%list(m)%tile_id(tnbr) .NE. tilerecv(n) ) cycle
5655 isc = domain%list(m)%x(tnbr)%compute%begin; iec = domain%list(m)%x(tnbr)%compute%end
5656 jsc = domain%list(m)%y(tnbr)%compute%begin; jec = domain%list(m)%y(tnbr)%compute%end
5657 isc = max(isc, is2recv(n)); iec = min(iec, ie2recv(n))
5658 jsc = max(jsc, js2recv(n)); jec = min(jec, je2recv(n))
5659 if( isc > iec .OR. jsc > jec ) cycle
5662 nxc = iec - isc + 1; nyc = jec - jsc + 1
5663 select case ( align2recv(n) )
5665 if(align2recv(n) == west)
then
5666 ioff = isc - is2recv(n)
5668 ioff = ie2recv(n) - iec
5670 joff = jsc - js2recv(n)
5671 case ( north, south )
5672 ioff = isc - is2recv(n)
5673 if(align2recv(n) == south)
then
5674 joff = jsc - js2recv(n)
5676 joff = je2recv(n) - jec
5681 select case ( rotaterecv(n) )
5683 isd1 = is1recv(n) + ioff; ied1 = isd1 + nxc - 1
5684 jsd1 = js1recv(n) + joff; jed1 = jsd1 + nyc - 1
5685 if( align1recv(n) == west )
then
5686 ied1 = ie1recv(n)-ioff; isd1 = ied1 - nxc + 1
5688 if( align1recv(n) == south )
then
5689 jed1 = je1recv(n)-joff; jsd1 = jed1 - nyc + 1
5692 if( align1recv(n) == west )
then
5693 ied1 = ie1recv(n)-joff; isd1 = ied1 - nyc + 1
5695 isd1 = is1recv(n)+joff; ied1 = isd1 + nyc - 1
5697 jed1 = je1recv(n) - ioff; jsd1 = jed1 - nxc + 1
5698 case ( minus_ninety )
5699 ied1 = ie1recv(n) - joff; isd1 = ied1 - nyc + 1
5700 if( align1recv(n) == south )
then
5701 jed1 = je1recv(n)-ioff; jsd1 = jed1 - nxc + 1
5703 jsd1 = js1recv(n)+ioff; jed1 = jsd1 + nxc - 1
5711 if( align1recv(n) .NE. east ) cycle
5712 isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5713 jsd2 = domain%y(tme)%compute%begin; jed2 = domain%y(tme)%compute%end
5715 isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5716 jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5718 if( align1recv(n) .NE. south ) cycle
5719 isd2 = domain%x(tme)%compute%begin; ied2 = domain%x(tme)%compute%end
5720 jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5722 isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5723 jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5725 if( align1recv(n) .NE. west ) cycle
5726 isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5727 jsd2 = domain%y(tme)%compute%begin; jed2 = domain%y(tme)%compute%end
5729 isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5730 jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5732 if( align1recv(n) .NE. north ) cycle
5733 isd2 = domain%x(tme)%compute%begin; ied2 = domain%x(tme)%compute%end
5734 jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5736 isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5737 jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5739 is = max(isd1,isd2); ie = min(ied1,ied2)
5740 js = max(jsd1,jsd2); je = min(jed1,jed2)
5741 if(ie.GE.is .AND. je.GE.js )
then
5742 if(.not.
associated(overlaprecv(m)%tileMe))
call allocate_update_overlap(overlaprecv(m), &
5744 call insert_overlap_type(overlaprecv(m), domain%list(m)%pe, tme, tnbr, &
5745 is, ie, js, je, dir, rotaterecv(n), .true.)
5746 count = overlaprecv(m)%count
5755 nsend = 0; nsend2 = 0
5756 do list = 0, nlist-1
5757 m = mod( domain%pos+list, nlist )
5758 if(overlapsend(m)%count>0) nsend = nsend + 1
5761 if(debug_message_passing)
then
5764 do list = 0, nlist-1
5765 m = mod( domain%pos+list, nlist )
5766 if(overlapsend(m)%count==0) cycle
5767 write(iunit, *)
"********to_pe = " ,overlapsend(m)%pe,
" count = ",overlapsend(m)%count
5768 do n = 1, overlapsend(m)%count
5769 write(iunit, *) overlapsend(m)%is(n), overlapsend(m)%ie(n), overlapsend(m)%js(n), overlapsend(m)%je(n), &
5770 overlapsend(m)%dir(n), overlapsend(m)%rotation(n)
5773 if(nsend >0)
flush(iunit)
5776 dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
5777 dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
5781 if(
associated(domain%update_T%send))
then
5782 do m = 1, domain%update_T%nsend
5783 call deallocate_overlap_type(domain%update_T%send(m))
5785 deallocate(domain%update_T%send)
5787 domain%update_T%nsend = nsend
5788 allocate(domain%update_T%send(nsend))
5789 do list = 0, nlist-1
5790 m = mod( domain%pos+list, nlist )
5791 ntilenbr =
size(domain%list(m)%x(:))
5793 if(overlapsend(m)%count > 0)
then
5795 if(nsend2>nsend)
call mpp_error(fatal, &
5796 "mpp_domains_define.inc(define_contact_point): nsend2 is greater than nsend")
5797 call allocate_update_overlap(domain%update_T%send(nsend2), overlapsend(m)%count)
5799 do tnbr = 1, ntilenbr
5801 if(domain%list(m)%pe == domain%pe)
then
5803 if(tme > ntileme) tme = tme - ntileme
5808 do l = 1, overlapsend(m)%count
5809 if(overlapsend(m)%tileMe(l) .NE. tme) cycle
5810 if(overlapsend(m)%tileNbr(l) .NE. tnbr) cycle
5811 if(overlapsend(m)%dir(l) .NE. dirlist(n) ) cycle
5812 call insert_overlap_type(domain%update_T%send(nsend2), overlapsend(m)%pe, &
5813 overlapsend(m)%tileMe(l), overlapsend(m)%tileNbr(l), overlapsend(m)%is(l), &
5814 overlapsend(m)%ie(l), overlapsend(m)%js(l), overlapsend(m)%je(l), overlapsend(m)%dir(l),&
5815 overlapsend(m)%rotation(l), overlapsend(m)%from_contact(l) )
5824 if(nsend2 .NE. nsend)
call mpp_error(fatal, &
5825 "mpp_domains_define.inc(define_contact_point): nsend2 does not equal to nsend")
5827 nrecv = 0; nrecv2 = 0
5828 do list = 0, nlist-1
5829 m = mod( domain%pos+list, nlist )
5830 if(overlaprecv(m)%count>0) nrecv = nrecv + 1
5833 if(debug_message_passing)
then
5834 do list = 0, nlist-1
5835 m = mod( domain%pos+list, nlist )
5836 if(overlaprecv(m)%count==0) cycle
5837 write(iunit, *)
"********from_pe = " ,overlaprecv(m)%pe,
" count = ",overlaprecv(m)%count
5838 do n = 1, overlaprecv(m)%count
5839 write(iunit, *) overlaprecv(m)%is(n), overlaprecv(m)%ie(n), overlaprecv(m)%js(n), overlaprecv(m)%je(n), &
5840 overlaprecv(m)%dir(n), overlaprecv(m)%rotation(n)
5843 if(nrecv >0)
flush(iunit)
5847 if(
associated(domain%update_T%recv))
then
5848 do m = 1, domain%update_T%nrecv
5849 call deallocate_overlap_type(domain%update_T%recv(m))
5851 deallocate(domain%update_T%recv)
5853 domain%update_T%nrecv = nrecv
5854 allocate(domain%update_T%recv(nrecv))
5856 do list = 0, nlist-1
5857 m = mod( domain%pos+nlist-list, nlist )
5858 ntilenbr =
size(domain%list(m)%x(:))
5859 if(overlaprecv(m)%count > 0)
then
5861 if(nrecv2>nrecv)
call mpp_error(fatal, &
5862 "mpp_domains_define.inc(define_contact_point): nrecv2 is greater than nrecv")
5863 call allocate_update_overlap(domain%update_T%recv(nrecv2), overlaprecv(m)%count)
5867 if(domain%list(m)%pe == domain%pe)
then
5869 if(tnbr>ntilenbr) tnbr = tnbr - ntilenbr
5874 do l = 1, overlaprecv(m)%count
5875 if(overlaprecv(m)%tileMe(l) .NE. tme) cycle
5876 if(overlaprecv(m)%tileNbr(l) .NE. tnbr) cycle
5877 if(overlaprecv(m)%dir(l) .NE. dirlist(n) ) cycle
5878 call insert_overlap_type(domain%update_T%recv(nrecv2), overlaprecv(m)%pe, &
5879 overlaprecv(m)%tileMe(l), overlaprecv(m)%tileNbr(l), overlaprecv(m)%is(l), &
5880 overlaprecv(m)%ie(l), overlaprecv(m)%js(l), overlaprecv(m)%je(l), overlaprecv(m)%dir(l),&
5881 overlaprecv(m)%rotation(l), overlaprecv(m)%from_contact(l))
5882 count = domain%update_T%recv(nrecv2)%count
5891 if(nrecv2 .NE. nrecv)
call mpp_error(fatal, &
5892 "mpp_domains_define.inc(define_contact_point): nrecv2 does not equal to nrecv")
5895 call deallocate_overlap_type(overlapsend(m))
5896 call deallocate_overlap_type(overlaprecv(m))
5900 deallocate(econt(n)%tile, wcont(n)%tile, scont(n)%tile, ncont(n)%tile )
5901 deallocate(econt(n)%align1, wcont(n)%align1, scont(n)%align1, ncont(n)%align1)
5902 deallocate(econt(n)%align2, wcont(n)%align2, scont(n)%align2, ncont(n)%align2)
5903 deallocate(econt(n)%refine1, wcont(n)%refine1, scont(n)%refine1, ncont(n)%refine1)
5904 deallocate(econt(n)%refine2, wcont(n)%refine2, scont(n)%refine2, ncont(n)%refine2)
5905 deallocate(econt(n)%is1, econt(n)%ie1, econt(n)%js1, econt(n)%je1 )
5906 deallocate(econt(n)%is2, econt(n)%ie2, econt(n)%js2, econt(n)%je2 )
5907 deallocate(wcont(n)%is1, wcont(n)%ie1, wcont(n)%js1, wcont(n)%je1 )
5908 deallocate(wcont(n)%is2, wcont(n)%ie2, wcont(n)%js2, wcont(n)%je2 )
5909 deallocate(scont(n)%is1, scont(n)%ie1, scont(n)%js1, scont(n)%je1 )
5910 deallocate(scont(n)%is2, scont(n)%ie2, scont(n)%js2, scont(n)%je2 )
5911 deallocate(ncont(n)%is1, ncont(n)%ie1, ncont(n)%js1, ncont(n)%je1 )
5912 deallocate(ncont(n)%is2, ncont(n)%ie2, ncont(n)%js2, ncont(n)%je2 )
5915 domain%initialized = .true.
5922 subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
5923 type(contact_type),
intent(inout) :: Contact
5924 integer,
intent(in) :: tile
5925 integer,
intent(in) :: is1, ie1, js1, je1
5926 integer,
intent(in) :: is2, ie2, js2, je2
5927 integer,
intent(in) :: align1, align2
5928 real,
intent(in) :: refine1, refine2
5931 do pos = 1, contact%ncontact
5934 if( js1 < contact%js1(pos) )
exit
5936 if( is1 < contact%is1(pos) )
exit
5940 contact%ncontact = contact%ncontact + 1
5941 do n = contact%ncontact, pos+1, -1
5942 contact%tile(n) = contact%tile(n-1)
5943 contact%align1(n) = contact%align1(n-1)
5944 contact%align2(n) = contact%align2(n-1)
5945 contact%is1(n) = contact%is1(n-1); contact%ie1(n) = contact%ie1(n-1)
5946 contact%js1(n) = contact%js1(n-1); contact%je1(n) = contact%je1(n-1)
5947 contact%is2(n) = contact%is2(n-1); contact%ie2(n) = contact%ie2(n-1)
5948 contact%js2(n) = contact%js2(n-1); contact%je2(n) = contact%je2(n-1)
5951 contact%tile(pos) = tile
5952 contact%align1(pos) = align1
5953 contact%align2(pos) = align2
5954 contact%refine1(pos) = refine1
5955 contact%refine2(pos) = refine2
5956 contact%is1(pos) = is1; contact%ie1(pos) = ie1
5957 contact%js1(pos) = js1; contact%je1(pos) = je1
5958 contact%is2(pos) = is2; contact%ie2(pos) = ie2
5959 contact%js2(pos) = js2; contact%je2(pos) = je2
5966 type(domain2d),
intent(inout) :: domain
5967 integer,
intent(in) :: position
5969 integer :: ishift, jshift, nlist, list, m, n
5970 integer :: ntileMe, tMe, dir, count, pos, nsend, nrecv
5971 integer :: isoff1, ieoff1, jsoff1, jeoff1
5972 type(overlap_type),
pointer :: ptrIn => null()
5973 type(overlapspec),
pointer :: update_in => null()
5974 type(overlapspec),
pointer :: update_out => null()
5975 type(overlap_type) :: overlapList(0:size(domain%list(:))-1)
5976 type(overlap_type) :: overlap
5979 update_in => domain%update_T
5980 select case(position)
5982 update_out => domain%update_C
5984 update_out => domain%update_E
5986 update_out => domain%update_N
5988 call mpp_error(fatal,
"mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
5991 update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
5992 update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
5993 update_out%whalo = update_in%whalo; update_out%ehalo = update_in%ehalo
5994 update_out%shalo = update_in%shalo; update_out%nhalo = update_in%nhalo
5996 nlist =
size(domain%list(:))
5997 ntileme =
size(domain%x(:))
5998 call allocate_update_overlap(overlap, maxoverlap)
6000 call init_overlap_type(overlaplist(m))
6004 nsend = update_out%nsend
6006 pos = update_out%send(m)%pe - mpp_root_pe()
6007 call add_update_overlap(overlaplist(pos), update_out%send(m))
6008 call deallocate_overlap_type(update_out%send(m))
6010 if(
ASSOCIATED(update_out%send) )
deallocate(update_out%send)
6013 nsend = update_in%nsend
6015 ptrin => update_in%send(m)
6016 pos = ptrin%pe - mpp_root_pe()
6017 do n = 1, ptrin%count
6020 if(ptrin%from_contact(n))
then
6023 select case(ptrin%rotation(n))
6025 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6027 isoff1 = 0; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6030 select case(ptrin%rotation(n))
6032 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6034 isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6036 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6039 select case(ptrin%rotation(n))
6041 isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6043 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = ishift
6046 select case(ptrin%rotation(n))
6048 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6050 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6052 isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6055 select case(ptrin%rotation(n))
6057 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6059 isoff1 = 0; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6062 select case(ptrin%rotation(n))
6064 isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6066 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6068 isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6071 select case(ptrin%rotation(n))
6073 isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6075 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = ishift
6078 select case(ptrin%rotation(n))
6080 isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6082 isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6084 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6087 call insert_overlap_type(overlap, ptrin%pe, ptrin%tileMe(n), ptrin%tileNbr(n), &
6088 ptrin%is(n) + isoff1, ptrin%ie(n) + ieoff1, ptrin%js(n) + jsoff1, &
6089 ptrin%je(n) + jeoff1, ptrin%dir(n), ptrin%rotation(n), ptrin%from_contact(n))
6092 if(overlap%count > 0)
then
6093 call add_update_overlap(overlaplist(pos), overlap)
6094 call init_overlap_type(overlap)
6099 do list = 0, nlist-1
6100 m = mod( domain%pos+list, nlist )
6101 if(overlaplist(m)%count>0) nsend = nsend+1
6104 update_out%nsend = nsend
6106 if (
associated(update_out%send))
deallocate(update_out%send)
6107 allocate(update_out%send(nsend))
6109 do list = 0, nlist-1
6110 m = mod( domain%pos+list, nlist )
6111 if(overlaplist(m)%count>0)
then
6113 if(pos>nsend)
call mpp_error(fatal, &
6114 "mpp_domains_define.inc(set_contact_point): pos should be no larger than nsend")
6115 call add_update_overlap(update_out%send(pos), overlaplist(m))
6116 call deallocate_overlap_type(overlaplist(m))
6119 if(pos .NE. nsend)
call mpp_error(fatal, &
6120 "mpp_domains_define.inc(set_contact_point): pos should equal to nsend")
6126 nrecv = update_out%nrecv
6128 pos = update_out%recv(m)%pe - mpp_root_pe()
6129 call add_update_overlap(overlaplist(pos), update_out%recv(m))
6130 call deallocate_overlap_type(update_out%recv(m))
6132 if(
ASSOCIATED(update_out%recv) )
deallocate(update_out%recv)
6135 nrecv = update_in%nrecv
6137 ptrin => update_in%recv(m)
6138 pos = ptrin%pe - mpp_root_pe()
6139 do n = 1, ptrin%count
6142 if(ptrin%from_contact(n))
then
6145 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6147 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6149 isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6151 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6153 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6155 isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6157 isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6159 isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6161 call insert_overlap_type(overlap, ptrin%pe, ptrin%tileMe(n), ptrin%tileNbr(n), &
6162 ptrin%is(n) + isoff1, ptrin%ie(n) + ieoff1, ptrin%js(n) + jsoff1, &
6163 ptrin%je(n) + jeoff1, ptrin%dir(n), ptrin%rotation(n), ptrin%from_contact(n))
6164 count = overlap%count
6167 if(overlap%count > 0)
then
6168 call add_update_overlap(overlaplist(pos), overlap)
6169 call init_overlap_type(overlap)
6171 do tme = 1,
size(domain%x(:))
6172 do n = 1, overlap%count
6173 if(overlap%tileMe(n) == tme)
then
6174 if(overlap%dir(n) == 1 ) domain%x(tme)%loffset = 0
6175 if(overlap%dir(n) == 7 ) domain%y(tme)%loffset = 0
6182 do list = 0, nlist-1
6183 m = mod( domain%pos+nlist-list, nlist )
6184 if(overlaplist(m)%count>0) nrecv = nrecv+1
6187 update_out%nrecv = nrecv
6189 if (
associated(update_out%recv))
deallocate(update_out%recv)
6190 allocate(update_out%recv(nrecv))
6192 do list = 0, nlist-1
6193 m = mod( domain%pos+nlist-list, nlist )
6194 if(overlaplist(m)%count>0)
then
6196 if(pos>nrecv)
call mpp_error(fatal, &
6197 "mpp_domains_define.inc(set_contact_point): pos should be no larger than nrecv")
6198 call add_update_overlap(update_out%recv(pos), overlaplist(m))
6199 call deallocate_overlap_type(overlaplist(m))
6202 if(pos .NE. nrecv)
call mpp_error(fatal, &
6203 "mpp_domains_define.inc(set_contact_point): pos should equal to nrecv")
6206 call deallocate_overlap_type(overlap)
6214 type(domain2d),
intent(in) :: domain
6215 integer,
intent(in) :: position
6216 integer :: nlist, m, n
6217 integer,
parameter :: MAXCOUNT = 100
6218 integer :: is, ie, js, je
6219 integer :: nsend, nrecv, pos, maxsize, rotation
6220 type(overlap_type) :: overlap
6221 type(overlapspec),
pointer :: update => null()
6222 type(overlapspec),
pointer :: check => null()
6224 select case(position)
6226 update => domain%update_C
6227 check => domain%check_C
6229 update => domain%update_E
6230 check => domain%check_E
6232 update => domain%update_N
6233 check => domain%check_N
6235 call mpp_error(fatal,
"mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
6238 check%xbegin = update%xbegin; check%xend = update%xend
6239 check%ybegin = update%ybegin; check%yend = update%yend
6242 if( .NOT. domain%symmetry )
return
6246 do m = 1, update%nsend
6247 do n = 1, update%send(m)%count
6248 if( update%send(m)%rotation(n) == one_hundred_eighty ) cycle
6249 if( ( (position == east .OR. position == corner) .AND. update%send(m)%dir(n) == 1 ) .OR. &
6250 ( (position == north .OR. position == corner) .AND. update%send(m)%dir(n) == 7 ) )
then
6251 maxsize = max(maxsize, update%send(m)%count)
6259 if (
associated(check%send))
deallocate(check%send)
6260 allocate(check%send(nsend))
6261 call allocate_check_overlap(overlap, maxsize)
6265 nlist =
size(domain%list(:))
6268 do m = 1, update%nsend
6269 do n = 1, update%send(m)%count
6270 if( update%send(m)%rotation(n) == one_hundred_eighty ) cycle
6272 if( (position == east .OR. position == corner) .AND. update%send(m)%dir(n) == 1 )
then
6273 rotation = update%send(m)%rotation(n)
6274 select case( rotation )
6276 is = update%send(m)%is(n) - 1
6278 js = update%send(m)%js(n)
6279 je = update%send(m)%je(n)
6281 is = update%send(m)%is(n)
6282 ie = update%send(m)%ie(n)
6283 js = update%send(m)%js(n) - 1
6286 call insert_check_overlap(overlap, update%send(m)%pe, &
6287 update%send(m)%tileMe(n), 1, rotation, is, ie, js, je)
6291 if( (position == north .OR. position == corner) .AND. update%send(m)%dir(n) == 7 )
then
6292 rotation = update%send(m)%rotation(n)
6293 select case( rotation )
6295 is = update%send(m)%is(n)
6296 ie = update%send(m)%ie(n)
6297 js = update%send(m)%js(n) - 1
6299 case( minus_ninety )
6300 is = update%send(m)%is(n) - 1
6302 js = update%send(m)%js(n)
6303 je = update%send(m)%je(n)
6305 call insert_check_overlap(overlap, update%send(m)%pe, &
6306 update%send(m)%tileMe(n), 4, rotation, is, ie, js, je)
6309 if(overlap%count>0)
then
6311 if(pos>nsend)
call mpp_error(fatal,
"mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6313 call init_overlap_type(overlap)
6317 if(pos .NE. nsend)
call mpp_error(fatal,
"mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6321 do m = 1, update%nrecv
6322 do n = 1, update%recv(m)%count
6323 if( update%recv(m)%rotation(n) == one_hundred_eighty ) cycle
6324 if( ( (position == east .OR. position == corner) .AND. update%recv(m)%dir(n) == 1 ) .OR. &
6325 ( (position == north .OR. position == corner) .AND. update%recv(m)%dir(n) == 7 ) )
then
6326 maxsize = max(maxsize, update%recv(m)%count)
6333 if(nsend>0)
call deallocate_overlap_type(overlap)
6336 if (
associated(check%recv))
deallocate(check%recv)
6337 allocate(check%recv(nrecv))
6338 call allocate_check_overlap(overlap, maxsize)
6342 do m = 1, update%nrecv
6343 do n = 1, update%recv(m)%count
6344 if( update%recv(m)%rotation(n) == one_hundred_eighty ) cycle
6345 if( (position == east .OR. position == corner) .AND. update%recv(m)%dir(n) == 1 )
then
6346 is = update%recv(m)%is(n) - 1
6348 js = update%recv(m)%js(n)
6349 je = update%recv(m)%je(n)
6350 call insert_check_overlap(overlap, update%recv(m)%pe, &
6351 update%recv(m)%tileMe(n), 1, update%recv(m)%rotation(n), is, ie, js, je)
6353 if( (position == north .OR. position == corner) .AND. update%recv(m)%dir(n) == 7 )
then
6354 is = update%recv(m)%is(n)
6355 ie = update%recv(m)%ie(n)
6356 js = update%recv(m)%js(n) - 1
6358 call insert_check_overlap(overlap, update%recv(m)%pe, &
6359 update%recv(m)%tileMe(n), 3, update%recv(m)%rotation(n), is, ie, js, je)
6362 if(overlap%count>0)
then
6364 if(pos>nrecv)
call mpp_error(fatal,
"mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6366 call init_overlap_type(overlap)
6370 if(pos .NE. nrecv)
call mpp_error(fatal,
"mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6371 if(nrecv>0)
call deallocate_overlap_type(overlap)
6378 type(domain2d),
intent(inout) :: domain
6379 integer,
intent(in) :: position
6380 integer :: m, n, l, count, dr, tMe
6381 integer,
parameter :: MAXCOUNT = 100
6382 integer,
dimension(MAXCOUNT) :: dir, rotation, is, ie, js, je, tileMe, index
6383 integer,
dimension(size(domain%x(:)), 4) :: nrecvl
6384 integer,
dimension(size(domain%x(:)), 4, MAXCOUNT) :: isl, iel, jsl, jel
6385 type(overlap_type),
pointer :: overlap => null()
6386 type(overlapspec),
pointer :: update => null()
6387 type(overlapspec),
pointer :: bound => null()
6388 integer :: nlist_send, nlist_recv, ishift, jshift
6389 integer :: ism, iem, jsm, jem, nsend, nrecv
6390 integer :: isg, ieg, jsg, jeg, nlist, list
6391 integer :: npes_x, npes_y, ipos, jpos, inbr, jnbr
6392 integer :: isc, iec, jsc, jec, my_pe
6393 integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
6394 integer :: is_south1, ie_south1, js_south1, je_south1
6395 integer :: is_south2, ie_south2, js_south2, je_south2
6396 integer :: is_west0, ie_west0, js_west0, je_west0
6397 integer :: is_west1, ie_west1, js_west1, je_west1
6398 integer :: is_west2, ie_west2, js_west2, je_west2
6399 logical :: x_cyclic, y_cyclic, folded_north
6401 is_south1=0; ie_south1=0; js_south1=0; je_south1=0
6402 is_south2=0; ie_south2=0; js_south2=0; je_south2=0
6403 is_west0=0; ie_west0=0; js_west0=0; je_west0=0
6404 is_west1=0; ie_west1=0; js_west1=0; je_west1=0
6405 is_west2=0; ie_west2=0; js_west2=0; je_west2=0
6408 if( position == center .OR. .NOT. domain%symmetry )
return
6410 call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
6411 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
6413 select case(position)
6415 update => domain%update_C
6416 bound => domain%bound_C
6418 update => domain%update_E
6419 bound => domain%bound_E
6421 update => domain%update_N
6422 bound => domain%bound_N
6424 call mpp_error( fatal,
"mpp_domains_mod(set_bound_overlap): invalid option of position")
6427 bound%xbegin = ism; bound%xend = iem + ishift
6428 bound%ybegin = jsm; bound%yend = jem + jshift
6430 nlist_send = max(update%nsend,4)
6431 nlist_recv = max(update%nrecv,4)
6432 bound%nsend = nlist_send
6433 bound%nrecv = nlist_recv
6434 if(nlist_send >0)
then
6435 if (
associated(bound%send))
deallocate(bound%send)
6436 allocate(bound%send(nlist_send))
6437 bound%send(:)%count = 0
6439 if(nlist_recv >0)
then
6440 if (
associated(bound%recv))
deallocate(bound%recv)
6441 allocate(bound%recv(nlist_recv))
6442 bound%recv(:)%count = 0
6445 nlist =
size(domain%list(:))
6447 npes_x =
size(domain%x(1)%list(:))
6448 npes_y =
size(domain%y(1)%list(:))
6449 x_cyclic = domain%x(1)%cyclic
6450 y_cyclic = domain%y(1)%cyclic
6451 folded_north = btest(domain%fold,north)
6452 ipos = domain%x(1)%pos
6453 jpos = domain%y(1)%pos
6454 isc = domain%x(1)%compute%begin; iec = domain%x(1)%compute%end
6455 jsc = domain%y(1)%compute%begin; jec = domain%y(1)%compute%end
6458 if(domain%ntiles == 1)
then
6462 pe_south1 = null_pe; pe_south2 = null_pe
6463 if( position == north .OR. position == corner )
then
6464 inbr = ipos; jnbr = jpos + 1
6465 if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6466 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6467 pe_south1 = domain%pearray(inbr,jnbr)
6468 is_south1 = isc + ishift; ie_south1 = iec+ishift
6469 js_south1 = jec + jshift; je_south1 = js_south1
6473 if( position == corner )
then
6474 inbr = ipos + 1; jnbr = jpos + 1
6475 if( inbr == npes_x .AND. x_cyclic) inbr = 0
6476 if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6477 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6478 pe_south2 = domain%pearray(inbr,jnbr)
6479 is_south2 = iec + ishift; ie_south2 = is_south2
6480 js_south2 = jec + jshift; je_south2 = js_south2
6485 pe_west0 = null_pe; pe_west1 = null_pe; pe_west2 = null_pe
6486 if( position == east )
then
6487 inbr = ipos+1; jnbr = jpos
6488 if( inbr == npes_x .AND. x_cyclic) inbr = 0
6489 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6490 pe_west1 = domain%pearray(inbr,jnbr)
6491 is_west1 = iec + ishift; ie_west1 = is_west1
6492 js_west1 = jsc + jshift; je_west1 = jec + jshift
6494 else if ( position == corner )
then
6496 if( folded_north .AND. jec == jeg .AND. ipos .LT. (npes_x-1)/2 )
then
6497 inbr = npes_x - ipos - 1; jnbr = jpos
6498 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6499 pe_west0 = domain%pearray(inbr,jnbr)
6500 is_west0 = iec+ishift; ie_west0 = is_west0
6501 js_west0 = jec+jshift; je_west0 = js_west0
6505 if( folded_north .AND. jec == jeg .AND. ipos .GE. npes_x/2 .AND. ipos .LT. (npes_x-1) )
then
6506 inbr = ipos+1; jnbr = jpos
6507 if( inbr == npes_x .AND. x_cyclic) inbr = 0
6508 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6509 pe_west1 = domain%pearray(inbr,jnbr)
6510 is_west1 = iec + ishift; ie_west1 = is_west1
6511 js_west1 = jsc + jshift; je_west1 = jec
6514 inbr = ipos+1; jnbr = jpos
6515 if( inbr == npes_x .AND. x_cyclic) inbr = 0
6516 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6517 pe_west1 = domain%pearray(inbr,jnbr)
6518 is_west1 = iec + ishift; ie_west1 = is_west1
6519 js_west1 = jsc + jshift; je_west1 = jec + jshift
6524 if( position == corner )
then
6525 inbr = ipos + 1; jnbr = jpos + 1
6526 if( inbr == npes_x .AND. x_cyclic) inbr = 0
6527 if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6528 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6529 pe_west2 = domain%pearray(inbr,jnbr)
6530 is_west2 = iec + ishift; ie_west2 = is_west2
6531 js_west2 = jec + jshift; je_west2 = js_west2
6536 m = mod( domain%pos+list, nlist )
6538 my_pe = domain%list(m)%pe
6539 if(my_pe == pe_south1)
then
6541 is(count) = is_south1; ie(count) = ie_south1
6542 js(count) = js_south1; je(count) = je_south1
6544 rotation(count) = zero
6546 if(my_pe == pe_south2)
then
6548 is(count) = is_south2; ie(count) = ie_south2
6549 js(count) = js_south2; je(count) = je_south2
6551 rotation(count) = zero
6554 if(my_pe == pe_west0)
then
6556 is(count) = is_west0; ie(count) = ie_west0
6557 js(count) = js_west0; je(count) = je_west0
6559 rotation(count) = one_hundred_eighty
6561 if(my_pe == pe_west1)
then
6563 is(count) = is_west1; ie(count) = ie_west1
6564 js(count) = js_west1; je(count) = je_west1
6566 rotation(count) = zero
6568 if(my_pe == pe_west2)
then
6570 is(count) = is_west2; ie(count) = ie_west2
6571 js(count) = js_west2; je(count) = je_west2
6573 rotation(count) = zero
6578 if(nsend > nlist_send)
call mpp_error(fatal,
"set_bound_overlap: nsend > nlist_send")
6579 bound%send(nsend)%count = count
6580 bound%send(nsend)%pe = my_pe
6581 if (
associated(bound%send(nsend)%is))
deallocate(bound%send(nsend)%is)
6582 if (
associated(bound%send(nsend)%ie))
deallocate(bound%send(nsend)%ie)
6583 if (
associated(bound%send(nsend)%js))
deallocate(bound%send(nsend)%js)
6584 if (
associated(bound%send(nsend)%je))
deallocate(bound%send(nsend)%je)
6585 if (
associated(bound%send(nsend)%dir))
deallocate(bound%send(nsend)%dir)
6586 if (
associated(bound%send(nsend)%rotation))
deallocate(bound%send(nsend)%rotation)
6587 if (
associated(bound%send(nsend)%tileMe))
deallocate(bound%send(nsend)%tileMe)
6588 allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6589 allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6590 allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6591 allocate(bound%send(nsend)%tileMe(count))
6592 bound%send(nsend)%is(:) = is(1:count)
6593 bound%send(nsend)%ie(:) = ie(1:count)
6594 bound%send(nsend)%js(:) = js(1:count)
6595 bound%send(nsend)%je(:) = je(1:count)
6596 bound%send(nsend)%dir(:) = dir(1:count)
6597 bound%send(nsend)%tileMe(:) = 1
6598 bound%send(nsend)%rotation(:) = rotation(1:count)
6603 do m = 1, update%nsend
6604 overlap => update%send(m)
6605 if( overlap%count == 0 ) cycle
6607 do n = 1, overlap%count
6609 if( overlap%rotation(n) == one_hundred_eighty ) cycle
6610 if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 1)
then
6613 rotation(count) = overlap%rotation(n)
6614 tileme(count) = overlap%tileMe(n)
6615 select case( rotation(count) )
6617 is(count) = overlap%is(n) - 1
6618 ie(count) = is(count)
6619 js(count) = overlap%js(n)
6620 je(count) = overlap%je(n)
6622 is(count) = overlap%is(n)
6623 ie(count) = overlap%ie(n)
6624 js(count) = overlap%js(n) - 1
6625 je(count) = js(count)
6628 if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 3 )
then
6631 rotation(count) = overlap%rotation(n)
6632 tileme(count) = overlap%tileMe(n)
6633 select case( rotation(count) )
6635 is(count) = overlap%is(n)
6636 ie(count) = overlap%ie(n)
6637 js(count) = overlap%je(n) + 1
6638 je(count) = js(count)
6639 case( minus_ninety )
6640 is(count) = overlap%ie(n) + 1
6641 ie(count) = is(count)
6642 js(count) = overlap%js(n)
6643 je(count) = overlap%je(n)
6646 if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 5 )
then
6649 rotation(count) = overlap%rotation(n)
6650 tileme(count) = overlap%tileMe(n)
6651 select case( rotation(count) )
6653 is(count) = overlap%ie(n) + 1
6654 ie(count) = is(count)
6655 js(count) = overlap%js(n)
6656 je(count) = overlap%je(n)
6658 is(count) = overlap%is(n)
6659 ie(count) = overlap%ie(n)
6660 js(count) = overlap%je(n) + 1
6661 je(count) = js(count)
6664 if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 7 )
then
6667 rotation(count) = overlap%rotation(n)
6668 tileme(count) = overlap%tileMe(n)
6669 select case( rotation(count) )
6671 is(count) = overlap%is(n)
6672 ie(count) = overlap%ie(n)
6673 js(count) = overlap%js(n) - 1
6674 je(count) = js(count)
6675 case( minus_ninety )
6676 is(count) = overlap%is(n) - 1
6677 ie(count) = is(count)
6678 js(count) = overlap%js(n)
6679 je(count) = overlap%je(n)
6685 bound%send(nsend)%count = count
6686 bound%send(nsend)%pe = overlap%pe
6687 if (
associated(bound%send(nsend)%is))
deallocate(bound%send(nsend)%is)
6688 if (
associated(bound%send(nsend)%ie))
deallocate(bound%send(nsend)%ie)
6689 if (
associated(bound%send(nsend)%js))
deallocate(bound%send(nsend)%js)
6690 if (
associated(bound%send(nsend)%je))
deallocate(bound%send(nsend)%je)
6691 if (
associated(bound%send(nsend)%dir))
deallocate(bound%send(nsend)%dir)
6692 if (
associated(bound%send(nsend)%rotation))
deallocate(bound%send(nsend)%rotation)
6693 if (
associated(bound%send(nsend)%tileMe))
deallocate(bound%send(nsend)%tileMe)
6694 allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6695 allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6696 allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6697 allocate(bound%send(nsend)%tileMe(count))
6698 bound%send(nsend)%is(:) = is(1:count)
6699 bound%send(nsend)%ie(:) = ie(1:count)
6700 bound%send(nsend)%js(:) = js(1:count)
6701 bound%send(nsend)%je(:) = je(1:count)
6702 bound%send(nsend)%dir(:) = dir(1:count)
6703 bound%send(nsend)%tileMe(:) = tileme(1:count)
6704 bound%send(nsend)%rotation(:) = rotation(1:count)
6715 if( domain%ntiles == 1 )
then
6719 pe_south1 = null_pe; pe_south2 = null_pe
6720 if( position == north .OR. position == corner )
then
6721 inbr = ipos; jnbr = jpos - 1
6722 if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6723 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6724 pe_south1 = domain%pearray(inbr,jnbr)
6725 is_south1 = isc + ishift; ie_south1 = iec+ishift
6726 js_south1 = jsc; je_south1 = js_south1
6731 if( position == corner )
then
6732 inbr = ipos - 1; jnbr = jpos - 1
6733 if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6734 if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6735 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6736 pe_south2 = domain%pearray(inbr,jnbr)
6737 is_south2 = isc; ie_south2 = is_south2
6738 js_south2 = jsc; je_south2 = js_south2
6744 pe_west0 = null_pe; pe_west1 = null_pe; pe_west2 = null_pe
6745 if( position == east )
then
6746 inbr = ipos-1; jnbr = jpos
6747 if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6748 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6749 pe_west1 = domain%pearray(inbr,jnbr)
6750 is_west1 = isc; ie_west1 = is_west1
6751 js_west1 = jsc + jshift; je_west1 = jec + jshift
6753 else if ( position == corner )
then
6755 if( folded_north .AND. jec == jeg .AND. ipos .GT. npes_x/2 )
then
6756 inbr = npes_x - ipos - 1; jnbr = jpos
6757 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6758 pe_west0 = domain%pearray(inbr,jnbr)
6759 is_west0 = isc; ie_west0 = is_west0
6760 js_west0 = jec+jshift; je_west0 = js_west0
6762 inbr = ipos-1; jnbr = jpos
6763 if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6764 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6765 pe_west1 = domain%pearray(inbr,jnbr)
6766 is_west1 = isc; ie_west1 = is_west1
6767 js_west1 = jsc + jshift; je_west1 = jec
6770 inbr = ipos-1; jnbr = jpos
6771 if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6772 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6773 pe_west1 = domain%pearray(inbr,jnbr)
6774 is_west1 = isc; ie_west1 = is_west1
6775 js_west1 = jsc + jshift; je_west1 = jec+jshift
6781 if( position == corner )
then
6782 inbr = ipos - 1; jnbr = jpos - 1
6783 if( inbr == -1 .AND. x_cyclic) inbr = npes_x - 1
6784 if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y - 1
6785 if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y )
then
6786 pe_west2 = domain%pearray(inbr,jnbr)
6787 is_west2 = isc; ie_west2 = is_west2
6788 js_west2 = jsc; je_west2 = js_west2
6794 m = mod( domain%pos+nlist-list, nlist )
6796 my_pe = domain%list(m)%pe
6797 if(my_pe == pe_south1)
then
6799 is(count) = is_south1; ie(count) = ie_south1
6800 js(count) = js_south1; je(count) = je_south1
6802 rotation(count) = zero
6803 index(count) = 1 + ishift
6805 if(my_pe == pe_south2)
then
6807 is(count) = is_south2; ie(count) = ie_south2
6808 js(count) = js_south2; je(count) = je_south2
6810 rotation(count) = zero
6813 if(my_pe == pe_west0)
then
6815 is(count) = is_west0; ie(count) = ie_west0
6816 js(count) = js_west0; je(count) = je_west0
6818 rotation(count) = one_hundred_eighty
6819 index(count) = jec-jsc+1+jshift
6821 if(my_pe == pe_west1)
then
6823 is(count) = is_west1; ie(count) = ie_west1
6824 js(count) = js_west1; je(count) = je_west1
6826 rotation(count) = zero
6827 index(count) = 1 + jshift
6829 if(my_pe == pe_west2)
then
6831 is(count) = is_west2; ie(count) = ie_west2
6832 js(count) = js_west2; je(count) = je_west2
6834 rotation(count) = zero
6840 if(nrecv > nlist_recv)
call mpp_error(fatal,
"set_bound_overlap: nrecv > nlist_recv")
6841 bound%recv(nrecv)%count = count
6842 bound%recv(nrecv)%pe = my_pe
6843 if (
associated(bound%recv(nrecv)%is))
deallocate(bound%recv(nrecv)%is)
6844 if (
associated(bound%recv(nrecv)%ie))
deallocate(bound%recv(nrecv)%ie)
6845 if (
associated(bound%recv(nrecv)%js))
deallocate(bound%recv(nrecv)%js)
6846 if (
associated(bound%recv(nrecv)%je))
deallocate(bound%recv(nrecv)%je)
6847 if (
associated(bound%recv(nrecv)%dir))
deallocate(bound%recv(nrecv)%dir)
6848 if (
associated(bound%recv(nrecv)%index))
deallocate(bound%recv(nrecv)%index)
6849 if (
associated(bound%recv(nrecv)%tileMe))
deallocate(bound%recv(nrecv)%tileMe)
6850 if (
associated(bound%recv(nrecv)%rotation))
deallocate(bound%recv(nrecv)%rotation)
6851 allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6852 allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6853 allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6854 allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6856 bound%recv(nrecv)%is(:) = is(1:count)
6857 bound%recv(nrecv)%ie(:) = ie(1:count)
6858 bound%recv(nrecv)%js(:) = js(1:count)
6859 bound%recv(nrecv)%je(:) = je(1:count)
6860 bound%recv(nrecv)%dir(:) = dir(1:count)
6861 bound%recv(nrecv)%tileMe(:) = 1
6862 bound%recv(nrecv)%rotation(:) = rotation(1:count)
6863 bound%recv(nrecv)%index(:) = index(1:count)
6867 do m = 1, update%nrecv
6868 overlap => update%recv(m)
6869 if( overlap%count == 0 ) cycle
6871 do n = 1, overlap%count
6873 if( overlap%rotation(n) == one_hundred_eighty ) cycle
6874 if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 1)
then
6877 rotation(count) = overlap%rotation(n)
6878 tileme(count) = overlap%tileMe(n)
6879 is(count) = overlap%is(n) - 1
6880 ie(count) = is(count)
6881 js(count) = overlap%js(n)
6882 je(count) = overlap%je(n)
6884 nrecvl(tme, 1) = nrecvl(tme,1) + 1
6885 isl(tme,1,nrecvl(tme, 1)) = is(count)
6886 iel(tme,1,nrecvl(tme, 1)) = ie(count)
6887 jsl(tme,1,nrecvl(tme, 1)) = js(count)
6888 jel(tme,1,nrecvl(tme, 1)) = je(count)
6891 if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 3)
then
6894 rotation(count) = overlap%rotation(n)
6895 tileme(count) = overlap%tileMe(n)
6896 is(count) = overlap%is(n)
6897 ie(count) = overlap%ie(n)
6898 js(count) = overlap%je(n) + 1
6899 je(count) = js(count)
6901 nrecvl(tme, 2) = nrecvl(tme,2) + 1
6902 isl(tme,2,nrecvl(tme, 2)) = is(count)
6903 iel(tme,2,nrecvl(tme, 2)) = ie(count)
6904 jsl(tme,2,nrecvl(tme, 2)) = js(count)
6905 jel(tme,2,nrecvl(tme, 2)) = je(count)
6908 if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 5)
then
6911 rotation(count) = overlap%rotation(n)
6912 tileme(count) = overlap%tileMe(n)
6913 is(count) = overlap%ie(n) + 1
6914 ie(count) = is(count)
6915 js(count) = overlap%js(n)
6916 je(count) = overlap%je(n)
6918 nrecvl(tme, 3) = nrecvl(tme,3) + 1
6919 isl(tme,3,nrecvl(tme, 3)) = is(count)
6920 iel(tme,3,nrecvl(tme, 3)) = ie(count)
6921 jsl(tme,3,nrecvl(tme, 3)) = js(count)
6922 jel(tme,3,nrecvl(tme, 3)) = je(count)
6925 if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 7)
then
6928 rotation(count) = overlap%rotation(n)
6929 tileme(count) = overlap%tileMe(n)
6930 is(count) = overlap%is(n)
6931 ie(count) = overlap%ie(n)
6932 js(count) = overlap%js(n) - 1
6933 je(count) = js(count)
6935 nrecvl(tme, 4) = nrecvl(tme,4) + 1
6936 isl(tme,4,nrecvl(tme, 4)) = is(count)
6937 iel(tme,4,nrecvl(tme, 4)) = ie(count)
6938 jsl(tme,4,nrecvl(tme, 4)) = js(count)
6939 jel(tme,4,nrecvl(tme, 4)) = je(count)
6944 bound%recv(nrecv)%count = count
6945 bound%recv(nrecv)%pe = overlap%pe
6946 if (
associated(bound%recv(nrecv)%is))
deallocate(bound%recv(nrecv)%is)
6947 if (
associated(bound%recv(nrecv)%ie))
deallocate(bound%recv(nrecv)%ie)
6948 if (
associated(bound%recv(nrecv)%js))
deallocate(bound%recv(nrecv)%js)
6949 if (
associated(bound%recv(nrecv)%je))
deallocate(bound%recv(nrecv)%je)
6950 if (
associated(bound%recv(nrecv)%dir))
deallocate(bound%recv(nrecv)%dir)
6951 if (
associated(bound%recv(nrecv)%index))
deallocate(bound%recv(nrecv)%index)
6952 if (
associated(bound%recv(nrecv)%tileMe))
deallocate(bound%recv(nrecv)%tileMe)
6953 if (
associated(bound%recv(nrecv)%rotation))
deallocate(bound%recv(nrecv)%rotation)
6954 allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6955 allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6956 allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6957 allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6958 bound%recv(nrecv)%is(:) = is(1:count)
6959 bound%recv(nrecv)%ie(:) = ie(1:count)
6960 bound%recv(nrecv)%js(:) = js(1:count)
6961 bound%recv(nrecv)%je(:) = je(1:count)
6962 bound%recv(nrecv)%dir(:) = dir(1:count)
6963 bound%recv(nrecv)%tileMe(:) = tileme(1:count)
6964 bound%recv(nrecv)%rotation(:) = rotation(1:count)
6969 do n = 1, bound%recv(m)%count
6970 tme = bound%recv(m)%tileMe(n)
6971 dr = bound%recv(m)%dir(n)
6972 bound%recv(m)%index(n) = 1
6973 do l = 1, nrecvl(tme,dr)
6974 if(dr == 1 .OR. dr == 3)
then
6975 if( bound%recv(m)%js(n) > jsl(tme, dr, l) )
then
6976 if( bound%recv(m)%rotation(n) == one_hundred_eighty )
then
6977 bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6978 max(abs(jel(tme, dr, l)-jsl(tme, dr, l))+1, &
6979 abs(iel(tme, dr, l)-isl(tme, dr, l))+1)
6981 bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6982 max(abs(jel(tme, dr, l)-jsl(tme, dr, l)), &
6983 abs(iel(tme, dr, l)-isl(tme, dr, l))) + 1 - jshift
6987 if( bound%recv(m)%is(n) > isl(tme, dr, l) )
then
6988 bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6989 max(abs(jel(tme, dr, l)-jsl(tme, dr, l)), &
6990 abs(iel(tme, dr, l)-isl(tme, dr, l))) + 1 - ishift
7006 subroutine fill_corner_contact(eCont, sCont, wCont, nCont, isg, ieg, jsg, jeg, numR, numS, tileRecv, tileSend, &
7007 is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv, &
7008 is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send, &
7009 align1Recv, align2Recv, align1Send, align2Send, &
7010 whalo, ehalo, shalo, nhalo, tileMe)
7011 type(contact_type),
dimension(:),
intent(in) :: eCont, sCont, wCont, nCont
7012 integer,
dimension(:),
intent(in) :: isg, ieg, jsg, jeg
7013 integer,
intent(inout) :: numR, numS
7014 integer,
dimension(:),
intent(inout) :: tileRecv, tileSend
7015 integer,
dimension(:),
intent(inout) :: is1Recv, ie1Recv, js1Recv, je1Recv
7016 integer,
dimension(:),
intent(inout) :: is2Recv, ie2Recv, js2Recv, je2Recv
7017 integer,
dimension(:),
intent(inout) :: is1Send, ie1Send, js1Send, je1Send
7018 integer,
dimension(:),
intent(inout) :: is2Send, ie2Send, js2Send, je2Send
7019 integer,
dimension(:),
intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
7020 integer,
intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
7021 integer :: is1, ie1, js1, je1, is2, ie2, js2, je2
7022 integer :: tn, tc, n, m
7023 logical :: found_corner
7025 found_corner = .false.
7027 if(econt(tileme)%ncontact > 0)
then
7028 if(econt(tileme)%js1(1) == jsg(tileme) )
then
7029 tn = econt(tileme)%tile(1)
7030 if(econt(tileme)%js2(1) > jsg(tn) )
then
7031 if( econt(tileme)%js2(1) - jsg(tn) < shalo )
call mpp_error(fatal, &
7032 "mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
7033 found_corner = .true.; tc = tn
7034 is1 = econt(tileme)%ie1(1) + 1; je1 = econt(tileme)%js1(1) - 1
7035 is2 = econt(tileme)%is2(1); je2 = econt(tileme)%js2(1) - 1
7036 else if(scont(tn)%ncontact >0)
then
7037 if(scont(tn)%is1(1) == isg(tn))
then
7038 found_corner = .true.; tc = scont(tn)%tile(1)
7039 is1 = econt(tileme)%ie1(1) + 1; je1 = econt(tileme)%js1(1) - 1
7040 is2 = scont(tn)%is2(1); je2 = scont(tn)%je2(1)
7045 if( .not. found_corner )
then
7046 n = scont(tileme)%ncontact
7048 if( scont(tileme)%ie1(n) == ieg(tileme))
then
7049 tn = scont(tileme)%tile(n)
7050 if(scont(tileme)%ie2(n) < ieg(tn) )
then
7051 if(ieg(tn) - scont(tileme)%ie2(n) < ehalo )
call mpp_error(fatal, &
7052 "mpp_domains_define.inc: southeast tile for recv 2 is not tiled properly")
7053 found_corner = .true.; tc = tn
7054 is1 = scont(tileme)%ie1(n) + 1; je1 = scont(tileme)%js1(n) - 1
7055 is2 = scont(tileme)%ie2(n) + 1; je2 = scont(tileme)%je2(n)
7056 else if(econt(tn)%ncontact >0)
then
7057 m = econt(tn)%ncontact
7058 if(econt(tn)%je1(m) == jeg(tn))
then
7059 found_corner = .true.; tc = econt(tn)%tile(m)
7060 is1 = scont(tileme)%ie1(n) + 1; je1 = scont(tileme)%js1(n) - 1
7061 is2 = econt(tn)%is2(m); je2 = econt(tn)%je2(m)
7067 if(found_corner)
then
7069 tilerecv(numr) = tc; align1recv(numr) = south_east; align2recv(numr) = north_west
7070 is1recv(numr) = is1; ie1recv(numr) = is1 + ehalo - 1
7071 js1recv(numr) = je1 - shalo + 1; je1recv(numr) = je1
7072 is2recv(numr) = is2; ie2recv(numr) = is2 + ehalo - 1
7073 js2recv(numr) = je2 - shalo + 1; je2recv(numr) = je2
7077 found_corner = .false.
7078 if(wcont(tileme)%ncontact > 0)
then
7079 if(wcont(tileme)%js1(1) == jsg(tileme) )
then
7080 tn = wcont(tileme)%tile(1)
7081 if(wcont(tileme)%js2(1) > jsg(tn) )
then
7082 if( wcont(tileme)%js2(1) - jsg(tn) < shalo )
call mpp_error(fatal, &
7083 "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7084 found_corner = .true.; tc = tn
7085 ie1 = wcont(tileme)%is1(1) - 1; je1 = wcont(tileme)%js1(1) - 1
7086 ie2 = wcont(tileme)%is2(1); je2 = wcont(tileme)%js2(1) - 1
7087 else if(scont(tn)%ncontact >0)
then
7088 n = scont(tn)%ncontact
7089 if(scont(tn)%ie1(n) == ieg(tn))
then
7090 found_corner = .true.; tc = scont(tn)%tile(n)
7091 ie1 = wcont(tileme)%is1(1) - 1; je1 = wcont(tileme)%js1(1) - 1
7092 ie2 = scont(tn)%ie2(1); je2 = scont(tn)%je2(1)
7097 if( .not. found_corner )
then
7098 n = scont(tileme)%ncontact
7100 if( scont(tileme)%is1(1) == isg(tileme))
then
7101 tn = scont(tileme)%tile(1)
7102 if(scont(tileme)%is2(1) > isg(tn) )
then
7103 if( scont(tileme)%is2(1)-isg(tn) < whalo )
call mpp_error(fatal, &
7104 "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7105 found_corner = .true.; tc = tn
7106 ie1 = scont(tileme)%is1(1) - 1; je1 = scont(tileme)%js1(1) - 1
7107 ie2 = scont(tileme)%is2(1) - 1; je2 = scont(tileme)%js2(1)
7108 else if(wcont(tn)%ncontact >0)
then
7109 m = wcont(tn)%ncontact
7110 if(wcont(tn)%je1(m) == jeg(tn))
then
7111 found_corner = .true.; tc = wcont(tn)%tile(m)
7112 ie1 = scont(tileme)%is1(1) - 1; je1 = scont(tileme)%js1(1) - 1
7113 ie2 = wcont(tn)%ie2(m); je2 = wcont(tn)%je2(m)
7119 if(found_corner)
then
7121 tilerecv(numr) = tc; align1recv(numr) = south_west; align2recv(numr) = north_east
7122 is1recv(numr) = ie1 - whalo + 1; ie1recv(numr) = ie1
7123 js1recv(numr) = je1 - shalo + 1; je1recv(numr) = je1
7124 is2recv(numr) = ie2 - whalo + 1; ie2recv(numr) = ie2
7125 js2recv(numr) = je2 - shalo + 1; je2recv(numr) = je2
7129 found_corner = .false.
7130 n = wcont(tileme)%ncontact
7132 if(wcont(tileme)%je1(n) == jeg(tileme) )
then
7133 tn = wcont(tileme)%tile(n)
7134 if(wcont(tileme)%je2(n) < jeg(tn) )
then
7135 if( jeg(tn) - wcont(tileme)%je2(n) < nhalo )
call mpp_error(fatal, &
7136 "mpp_domains_define.inc: northwest tile for recv 1 is not tiled properly")
7137 found_corner = .true.; tc = tn
7138 ie1 = wcont(tileme)%is1(n) - 1; js1 = wcont(tileme)%je1(n) + 1
7139 ie2 = wcont(tileme)%is2(n); js2 = wcont(tileme)%je2(n) + 1
7140 else if(ncont(tn)%ncontact >0)
then
7141 m = ncont(tn)%ncontact
7142 if(ncont(tn)%ie1(m) == ieg(tn))
then
7143 found_corner = .true.; tc = ncont(tn)%tile(m)
7144 ie1 = wcont(tileme)%is1(n) - 1; js1 = wcont(tileme)%je1(n) + 1
7145 ie2 = ncont(tn)%ie2(m); js2 = ncont(tn)%js2(m)
7150 if( .not. found_corner )
then
7151 if( ncont(tileme)%ncontact > 0)
then
7152 if( ncont(tileme)%is1(1) == isg(tileme))
then
7153 tn = ncont(tileme)%tile(1)
7154 if(ncont(tileme)%is2(1) > isg(tn) )
then
7155 if( ncont(tileme)%is2(1)-isg(tn) < whalo )
call mpp_error(fatal, &
7156 "mpp_domains_define.inc: northwest tile for recv 2 is not tiled properly")
7157 found_corner = .true.; tc = tn
7158 ie1 = ncont(tileme)%is1(1) - 1; js1 = ncont(tileme)%je1(1) + 1
7159 ie2 = ncont(tileme)%is2(1) - 1; js2 = ncont(tileme)%js2(1)
7160 else if(wcont(tn)%ncontact >0)
then
7161 if(wcont(tn)%js1(1) == jsg(tn))
then
7162 found_corner = .true.; tc = wcont(tn)%tile(1)
7163 ie1 = ncont(tileme)%is1(1) - 1; js1 = ncont(tileme)%je1(1) + 1
7164 ie2 = wcont(tn)%ie2(1); js2 = wcont(tn)%js2(1)
7170 if(found_corner)
then
7172 tilerecv(numr) = tc; align1recv(numr) =north_west; align2recv(numr) = south_east
7173 is1recv(numr) = ie1 - whalo + 1; ie1recv(numr) = ie1
7174 js1recv(numr) = js1; je1recv(numr) = js1 + nhalo - 1
7175 is2recv(numr) = ie2 - whalo + 1; ie2recv(numr) = ie2
7176 js2recv(numr) = js2; je2recv(numr) = js2 + nhalo - 1
7180 found_corner = .false.
7181 n = econt(tileme)%ncontact
7183 if(econt(tileme)%je1(n) == jeg(tileme) )
then
7184 tn = econt(tileme)%tile(n)
7185 if(econt(tileme)%je2(n) < jeg(tn) )
then
7186 if( jeg(tn) - econt(tileme)%je2(n) < nhalo )
call mpp_error(fatal, &
7187 "mpp_domains_define.inc: northeast tile for recv 1 is not tiled properly")
7188 found_corner = .true.; tc = tn
7189 is1 = econt(tileme)%ie1(n) + 1; js1 = econt(tileme)%je1(n) + 1
7190 is2 = econt(tileme)%is2(1); js2 = econt(tileme)%je2(1) + 1
7191 else if(ncont(tn)%ncontact >0)
then
7192 if(ncont(tn)%is1(1) == isg(tn))
then
7193 found_corner = .true.; tc = ncont(tn)%tile(1)
7194 is1 = econt(tileme)%ie1(n) + 1; js1 = econt(tileme)%je1(n) + 1
7195 is2 = ncont(tn)%is2(1); js2 = ncont(tn)%js2(1)
7200 if( .not. found_corner )
then
7201 n = ncont(tileme)%ncontact
7203 if( ncont(tileme)%ie1(n) == ieg(tileme))
then
7204 tn = ncont(tileme)%tile(n)
7205 if(ncont(tileme)%ie2(n) < ieg(tn) )
then
7206 if(ieg(tn) - scont(tileme)%ie2(n) < ehalo )
call mpp_error(fatal, &
7207 "mpp_domains_define.inc: northeast tile for recv 2 is not tiled properly")
7208 found_corner = .true.; tc = tn
7209 is1 = scont(tileme)%ie1(n) + 1; js1 = scont(tileme)%je1(n) + 1
7210 is2 = scont(tileme)%ie2(n) + 1; js2 = scont(tileme)%js2(n)
7211 else if(econt(tn)%ncontact >0)
then
7212 if(econt(tn)%js1(1) == jsg(tn))
then
7213 found_corner = .true.; tc = econt(tn)%tile(1)
7214 is1 = scont(tileme)%ie1(n) + 1; js1 = scont(tileme)%je1(n) + 1
7215 is2 = econt(tn)%is2(m); js2 = econt(tn)%js2(m)
7221 if(found_corner)
then
7223 tilerecv(numr) = tc; align1recv(numr) =north_east; align2recv(numr) = south_west
7224 is1recv(numr) = is1; ie1recv(numr) = is1 + ehalo - 1
7225 js1recv(numr) = js1; je1recv(numr) = js1 + nhalo - 1
7226 is2recv(numr) = is2; ie2recv(numr) = is2 + ehalo - 1
7227 js2recv(numr) = js2; je2recv(numr) = js2 + nhalo - 1
7231 do n = 1, wcont(tileme)%ncontact
7232 tn = wcont(tileme)%tile(n)
7233 if(wcont(tileme)%js2(n) == jsg(tn) )
then
7234 if(wcont(tileme)%js1(n) > jsg(tileme) )
then
7235 if( wcont(tileme)%js1(n) - jsg(tileme) < shalo )
call mpp_error(fatal, &
7236 "mpp_domains_define.inc: southeast tile for send 1 is not tiled properly")
7237 nums = nums+1; tilesend(nums) = tn
7238 align1send(nums) = north_west; align2send(nums) = south_east
7239 is1send(nums) = wcont(tileme)%is1(n); ie1send(nums) = is1send(nums) + ehalo - 1
7240 je1send(nums) = wcont(tileme)%js1(n) - 1; js1send(nums) = je1send(nums) - shalo + 1
7241 is2send(nums) = wcont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7242 je2send(nums) = wcont(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7246 do n = 1, ncont(tileme)%ncontact
7247 tn = ncont(tileme)%tile(n)
7248 if(ncont(tileme)%ie2(n) == ieg(tn) )
then
7249 if(ncont(tileme)%ie1(n) < ieg(tileme) )
then
7250 if( ieg(tileme) - ncont(tileme)%ie1(n) < ehalo )
call mpp_error(fatal, &
7251 "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7252 nums = nums+1; tilesend(nums) = tn
7253 align1send(nums) = north_west; align2send(nums) = south_east
7254 is1send(nums) = ncont(tileme)%ie1(n) + 1; ie1send(nums) = is1send(nums) + ehalo - 1
7255 je1send(nums) = ncont(tileme)%je1(n) ; js1send(nums) = je1send(nums) - shalo + 1
7256 is2send(nums) = ncont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7257 je2send(nums) = ncont(tileme)%je2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7263 n = wcont(tileme)%ncontact
7264 found_corner = .false.
7266 tn = wcont(tileme)%tile(n)
7267 if( wcont(tileme)%je1(n) == jeg(tileme) .AND. wcont(tileme)%je2(n) == jeg(tn) )
then
7268 m = ncont(tn)%ncontact
7270 tc = ncont(tn)%tile(m)
7271 if( ncont(tn)%ie1(m) == ieg(tn) .AND. ncont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7275 if( .not. found_corner )
then
7276 if( ncont(tileme)%ncontact > 0)
then
7277 tn = ncont(tileme)%tile(1)
7278 if( ncont(tileme)%is1(1) == isg(tileme) .AND. ncont(tileme)%is2(1) == isg(tn) )
then
7279 if(wcont(tn)%ncontact >0)
then
7280 tc = wcont(tn)%tile(1)
7281 if( wcont(tn)%js1(1) == jsg(tn) .AND. wcont(tn)%js2(1) == jsg(tc) ) found_corner = .true.
7287 if(found_corner)
then
7288 nums = nums+1; tilesend(nums) = tc
7289 align1send(nums) = north_west; align2send(nums) = south_east
7290 is1send(nums) = isg(tileme); ie1send(nums) = is1send(nums) + ehalo - 1
7291 je1send(nums) = jeg(tileme); js1send(nums) = je1send(nums) - shalo + 1
7292 is2send(nums) = ieg(tc) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7293 je2send(nums) = jsg(tc) - 1; js2send(nums) = je2send(nums) - shalo + 1
7297 do n = 1, econt(tileme)%ncontact
7298 tn = econt(tileme)%tile(n)
7299 if(econt(tileme)%js2(n) == jsg(tn) )
then
7300 if(econt(tileme)%js1(n) > jsg(tileme) )
then
7301 if( econt(tileme)%js1(n) - jsg(tileme) < shalo )
call mpp_error(fatal, &
7302 "mpp_domains_define.inc: southwest tile for send 1 is not tiled properly")
7303 nums = nums+1; tilesend(nums) = tn
7304 align1send(nums) = north_east; align2send(nums) = south_west
7305 ie1send(nums) = econt(tileme)%ie1(n); is1send(nums) = ie1send(nums) - whalo + 1
7306 je1send(nums) = econt(tileme)%js1(n) - 1; js1send(nums) = je1send(nums) - shalo + 1
7307 ie2send(nums) = econt(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7308 je2send(nums) = econt(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7312 do n = 1, ncont(tileme)%ncontact
7313 tn = ncont(tileme)%tile(n)
7314 if(ncont(tileme)%is2(n) == isg(tn) )
then
7315 if(ncont(tileme)%is1(n) > isg(tileme) )
then
7316 if( ncont(tileme)%is1(n) - isg(tileme) < whalo )
call mpp_error(fatal, &
7317 "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7318 nums = nums+1; tilesend(nums) = tn
7319 align1send(nums) = north_east; align2send(nums) = south_west
7320 ie1send(nums) = ncont(tileme)%is1(n) - 1; is1send(nums) = ie1send(nums) - whalo + 1
7321 ie1send(nums) = ncont(tileme)%je1(n) ; js1send(nums) = je1send(nums) - shalo + 1
7322 ie2send(nums) = ncont(tileme)%is2(n) - 1; is2send(nums) = je2send(nums) - whalo + 1
7323 je2send(nums) = ncont(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7329 n = econt(tileme)%ncontact
7330 found_corner = .false.
7332 tn = econt(tileme)%tile(n)
7333 if( econt(tileme)%je1(n) == jeg(tileme) .AND. econt(tileme)%je2(n) == jeg(tn) )
then
7334 if(ncont(tn)%ncontact >0)
then
7335 tc = ncont(tn)%tile(1)
7336 if( ncont(tn)%is1(1) == isg(tn) .AND. ncont(tn)%is2(n) == isg(tc) ) found_corner = .true.
7340 if( .not. found_corner )
then
7341 n = ncont(tileme)%ncontact
7343 tn = ncont(tileme)%tile(n)
7344 if( ncont(tileme)%ie1(n) == ieg(tileme) .AND. ncont(tileme)%ie2(n) == ieg(tn) )
then
7345 if(econt(tn)%ncontact >0)
then
7346 tc = econt(tn)%tile(1)
7347 if( econt(tn)%js1(1) == jsg(tn) .AND. econt(tn)%js2(n) == jsg(tc) ) found_corner = .true.
7353 if(found_corner)
then
7354 nums = nums+1; tilesend(nums) = tc
7355 align1send(nums) = north_east; align2send(nums) = south_west
7356 ie1send(nums) = ieg(tileme); is1send(nums) = ie1send(nums) - whalo + 1
7357 je1send(nums) = jeg(tileme); js1send(nums) = je1send(nums) - shalo + 1
7358 ie2send(nums) = isg(tc) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7359 je2send(nums) = jsg(tc) - 1; js2send(nums) = je2send(nums) - shalo + 1
7363 do n = 1, econt(tileme)%ncontact
7364 tn = econt(tileme)%tile(n)
7365 if(econt(tileme)%je2(n) == jeg(tn) )
then
7366 if(econt(tileme)%je1(n) < jeg(tileme) )
then
7367 if( jeg(tileme) - econt(tileme)%je1(n) < nhalo )
call mpp_error(fatal, &
7368 "mpp_domains_define.inc: northwest tile for send 1 is not tiled properly")
7369 nums = nums+1; tilesend(nums) = tn
7370 align1send(nums) = south_east; align2send(nums) = north_west
7371 ie1send(nums) = econt(tileme)%ie1(n) ; is1send(nums) = ie1send(nums) - whalo + 1
7372 js1send(nums) = econt(tileme)%je1(n) + 1; je1send(nums) = js1send(nums) + nhalo - 1
7373 ie2send(nums) = econt(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7374 js2send(nums) = econt(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7379 do n = 1, scont(tileme)%ncontact
7380 tn = scont(tileme)%tile(n)
7381 if(scont(tileme)%is2(n) == isg(tn) )
then
7382 if(scont(tileme)%is1(n) > isg(tileme) )
then
7383 if( scont(tileme)%is1(n) - isg(tileme) < whalo )
call mpp_error(fatal, &
7384 "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7385 nums = nums+1; tilesend(nums) = tn
7386 align1send(nums) = south_east; align2send(nums) = north_west
7387 ie1send(nums) = ncont(tileme)%is1(n) - 1; is1send(nums) = ie1send(nums) - whalo + 1
7388 js1send(nums) = ncont(tileme)%je1(n) ; je1send(nums) = js1send(nums) + nhalo - 1
7389 ie2send(nums) = ncont(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7390 js2send(nums) = ncont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7396 n = econt(tileme)%ncontact
7397 found_corner = .false.
7399 tn = econt(tileme)%tile(1)
7400 if( econt(tileme)%js1(1) == jsg(tileme) .AND. econt(tileme)%js2(1) == jsg(tn) )
then
7401 if(scont(tn)%ncontact >0)
then
7402 tc = scont(tn)%tile(1)
7403 if( scont(tn)%is1(1) == isg(tn) .AND. scont(tn)%is2(1) == isg(tc) ) found_corner = .true.
7407 if( .not. found_corner )
then
7408 n = scont(tileme)%ncontact
7409 found_corner = .false.
7411 tn = scont(tileme)%tile(n)
7412 if( scont(tileme)%ie1(n) == ieg(tileme) .AND. scont(tileme)%ie2(n) == ieg(tn) )
then
7413 if(econt(tn)%ncontact >0)
then
7414 tc = econt(tn)%tile(n)
7415 if( econt(tn)%je1(n) == jeg(tn) .AND. econt(tn)%je2(n) == jeg(tc) ) found_corner = .true.
7421 if(found_corner)
then
7422 nums = nums+1; tilesend(nums) = tc
7423 align1send(nums) = south_east; align2send(nums) = north_west
7424 ie1send(nums) = ieg(tileme); is1send(nums) = ie1send(nums) - whalo + 1
7425 js1send(nums) = jsg(tileme); je1send(nums) = js1send(nums) + nhalo - 1
7426 ie2send(nums) = isg(tc) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7427 js2send(nums) = jeg(tc) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7431 do n = 1, wcont(tileme)%ncontact
7432 tn = wcont(tileme)%tile(n)
7433 if(wcont(tileme)%je2(n) == jeg(tn) )
then
7434 if(wcont(tileme)%je1(n) < jeg(tileme) )
then
7435 if( jeg(tileme) - wcont(tileme)%je1(n) < nhalo )
call mpp_error(fatal, &
7436 "mpp_domains_define.inc: northeast tile for send 1 is not tiled properly")
7437 nums = nums+1; tilesend(nums) = tn
7438 align1send(nums) = south_west; align2send(nums) = north_east
7439 is1send(nums) = wcont(tileme)%is1(n) ; ie1send(nums) = is1send(nums) + ehalo - 1
7440 js1send(nums) = wcont(tileme)%je1(n) + 1; je1send(nums) = js1send(nums) + nhalo - 1
7441 is2send(nums) = wcont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7442 js2send(nums) = wcont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7447 do n = 1, scont(tileme)%ncontact
7448 tn = scont(tileme)%tile(n)
7449 if(scont(tileme)%ie2(n) == ieg(tn) )
then
7450 if(scont(tileme)%ie1(n) < ieg(tileme) )
then
7451 if( ieg(tileme) - scont(tileme)%ie1(n) < ehalo )
call mpp_error(fatal, &
7452 "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7453 nums = nums+1; tilesend(nums) = tn
7454 align1send(nums) = south_west; align2send(nums) = north_east
7455 is1send(nums) = scont(tileme)%ie1(n) + 1; ie1send(nums) = is1send(nums) + ehalo - 1
7456 js1send(nums) = scont(tileme)%js1(n) ; je1send(nums) = js1send(nums) + nhalo - 1
7457 is2send(nums) = scont(tileme)%ie2(n) + 1; ie2send(nums) = is1send(nums) + ehalo - 1
7458 js2send(nums) = scont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7464 n = wcont(tileme)%ncontact
7465 found_corner = .false.
7467 tn = wcont(tileme)%tile(1)
7468 if( wcont(tileme)%js1(n) == jsg(tileme) .AND. wcont(tileme)%js2(n) == jsg(tn) )
then
7469 m = scont(tn)%ncontact
7471 tc = scont(tn)%tile(m)
7472 if( scont(tn)%ie1(m) == ieg(tn) .AND. scont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7476 if( .not. found_corner )
then
7477 n = scont(tileme)%ncontact
7478 found_corner = .false.
7480 tn = scont(tileme)%tile(1)
7481 if( scont(tileme)%is1(1) == isg(tileme) .AND. scont(tileme)%is2(1) == isg(tn) )
then
7482 m = wcont(tn)%ncontact
7484 tc = wcont(tn)%tile(m)
7485 if( wcont(tn)%je1(m) == jeg(tn) .AND. wcont(tn)%je2(m) == jeg(tc) ) found_corner = .true.
7490 if(found_corner)
then
7491 nums = nums+1; tilesend(nums) = tc
7492 align1send(nums) = south_west; align2send(nums) = north_east
7493 is1send(nums) = isg(tileme); ie1send(nums) = is1send(nums) + ehalo - 1
7494 js1send(nums) = jsg(tileme); je1send(nums) = js1send(nums) + nhalo - 1
7495 is2send(nums) = ieg(tc) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7496 js2send(nums) = jeg(tc) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7499 end subroutine fill_corner_contact
7502 subroutine check_alignment( is, ie, js, je, isg, ieg, jsg, jeg, alignment )
7503 integer,
intent(inout) :: is, ie, js, je, isg, ieg, jsg, jeg
7504 integer,
intent(out) :: alignment
7508 if ( is == ie )
then
7509 if ( is == isg )
then
7511 else if ( is == ieg )
then
7514 call mpp_error(fatal,
'mpp_domains_define.inc: The contact region is not on the x-boundary of the tile')
7517 j = js; js = je; je = j
7519 else if ( js == je )
then
7520 if ( js == jsg )
then
7522 else if ( js == jeg )
then
7525 call mpp_error(fatal,
'mpp_domains_define.inc: The contact region is not on the y-boundary of the tile')
7528 i = is; is = ie; ie = i
7531 call mpp_error(fatal,
'mpp_domains_define.inc: The contact region should be line contact' )
7534 end subroutine check_alignment
7546 type(domain1d),
intent(in) :: domain_in
7547 type(domain1d),
intent(inout) :: domain_out
7548 integer,
intent(in),
optional :: hbegin, hend
7549 integer,
intent(in),
optional :: cbegin, cend
7551 integer,
intent(in),
optional :: gbegin, gend
7553 integer :: ndivs, global_indices(2)
7556 global_indices(1) = domain_in%global%begin; global_indices(2) = domain_in%global%end
7559 ndivs =
size(domain_in%list(:))
7563 if(domain_in%cyclic) flag = flag + cyclic_global_domain
7564 if(domain_in%domain_data%is_global) flag = flag + global_data_domain
7566 call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, &
7567 flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size )
7569 if(
present(cbegin)) domain_out%compute%begin = cbegin
7570 if(
present(cend)) domain_out%compute%end = cend
7571 domain_out%compute%size = domain_out%compute%end - domain_out%compute%begin + 1
7572 if(
present(gbegin)) domain_out%global%begin = gbegin
7573 if(
present(gend)) domain_out%global%end = gend
7574 domain_out%global%size = domain_out%global%end - domain_out%global%begin + 1
7580 subroutine mpp_modify_domain2d(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, &
7583 type(domain2d),
intent(in) :: domain_in
7584 type(domain2d),
intent(inout) :: domain_out
7585 integer,
intent(in),
optional :: isc, iec, jsc, jec
7587 integer,
intent(in),
optional :: isg, ieg, jsg, jeg
7589 integer,
intent(in),
optional :: whalo, ehalo, shalo, nhalo
7590 integer :: global_indices(4), layout(2)
7591 integer :: xflag, yflag, nlist, i
7593 if(
present(whalo) .or.
present(ehalo) .or.
present(shalo) .or.
present(nhalo) )
then
7595 global_indices(1) = domain_in%x(1)%global%begin; global_indices(2) = domain_in%x(1)%global%end
7596 global_indices(3) = domain_in%y(1)%global%begin; global_indices(4) = domain_in%y(1)%global%end
7599 layout(1) =
size(domain_in%x(1)%list(:)); layout(2) =
size(domain_in%y(1)%list(:))
7602 xflag = 0; yflag = 0
7603 if(domain_in%x(1)%cyclic) xflag = xflag + cyclic_global_domain
7604 if(domain_in%x(1)%domain_data%is_global) xflag = xflag + global_data_domain
7605 if(domain_in%y(1)%cyclic) yflag = yflag + cyclic_global_domain
7606 if(domain_in%y(1)%domain_data%is_global) yflag = yflag + global_data_domain
7608 call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, &
7609 xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, &
7610 shalo = shalo, nhalo = nhalo, &
7611 xextent = domain_in%x(1)%list(:)%compute%size, &
7612 yextent = domain_in%y(1)%list(:)%compute%size, &
7613 symmetry=domain_in%symmetry, &
7614 maskmap = domain_in%pearray .NE. null_pe )
7615 domain_out%ntiles = domain_in%ntiles
7616 domain_out%tile_id = domain_in%tile_id
7618 call mpp_define_null_domain(domain_out)
7619 nlist =
size(domain_in%list(:))
7620 if (
associated(domain_out%list))
deallocate(domain_out%list)
7621 allocate(domain_out%list(0:nlist-1) )
7623 allocate(domain_out%list(i)%tile_id(1))
7624 domain_out%list(i)%tile_id(1) = 1
7626 call mpp_modify_domain(domain_in%x(1), domain_out%x(1), isc, iec, isg, ieg)
7627 call mpp_modify_domain(domain_in%y(1), domain_out%y(1), jsc, jec, jsg, jeg)
7628 domain_out%ntiles = domain_in%ntiles
7629 domain_out%tile_id = domain_in%tile_id
7638 subroutine mpp_define_null_domain1d(domain)
7639 type(domain1d),
intent(inout) :: domain
7641 domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0
7642 domain%domain_data%begin = -1; domain%domain_data%end = -1; domain%domain_data%size = 0
7643 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
7646 end subroutine mpp_define_null_domain1d
7651 subroutine mpp_define_null_domain2d(domain)
7652 type(domain2d),
intent(inout) :: domain
7654 allocate(domain%x(1), domain%y(1), domain%tile_id(1))
7655 call mpp_define_null_domain(domain%x(1))
7656 call mpp_define_null_domain(domain%y(1))
7658 domain%tile_id(1) = 1
7660 domain%max_ntile_pe = 1
7661 domain%ncontacts = 0
7663 end subroutine mpp_define_null_domain2d
7667 subroutine mpp_deallocate_domain1d(domain)
7668 type(domain1d),
intent(inout) :: domain
7670 if(
ASSOCIATED(domain%list))
deallocate(domain%list)
7672 end subroutine mpp_deallocate_domain1d
7676 subroutine mpp_deallocate_domain2d(domain)
7677 type(domain2d),
intent(inout) :: domain
7679 call deallocate_domain2d_local(domain)
7680 if(
ASSOCIATED(domain%io_domain) )
then
7681 call deallocate_domain2d_local(domain%io_domain)
7682 deallocate(domain%io_domain)
7685 end subroutine mpp_deallocate_domain2d
7689 subroutine deallocate_domain2d_local(domain)
7690 type(domain2d),
intent(inout) :: domain
7691 integer :: i, ntileMe
7693 ntileme =
size(domain%x(:))
7695 if(
ASSOCIATED(domain%pearray))
deallocate(domain%pearray)
7697 call mpp_deallocate_domain1d(domain%x(i))
7698 call mpp_deallocate_domain1d(domain%y(i))
7700 deallocate(domain%x, domain%y, domain%tile_id)
7703 if(
ASSOCIATED(domain%tileList))
deallocate(domain%tileList)
7704 if(
ASSOCIATED(domain%tile_id_all))
deallocate(domain%tile_id_all)
7706 if(
ASSOCIATED(domain%list))
then
7707 do i = 0,
size(domain%list(:))-1
7708 deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id)
7710 deallocate(domain%list)
7713 if(
ASSOCIATED(domain%check_C))
then
7714 call deallocate_overlapspec(domain%check_C)
7715 deallocate(domain%check_C)
7718 if(
ASSOCIATED(domain%check_E))
then
7719 call deallocate_overlapspec(domain%check_E)
7720 deallocate(domain%check_E)
7723 if(
ASSOCIATED(domain%check_N))
then
7724 call deallocate_overlapspec(domain%check_N)
7725 deallocate(domain%check_N)
7728 if(
ASSOCIATED(domain%bound_C))
then
7729 call deallocate_overlapspec(domain%bound_C)
7730 deallocate(domain%bound_C)
7733 if(
ASSOCIATED(domain%bound_E))
then
7734 call deallocate_overlapspec(domain%bound_E)
7735 deallocate(domain%bound_E)
7738 if(
ASSOCIATED(domain%bound_N))
then
7739 call deallocate_overlapspec(domain%bound_N)
7740 deallocate(domain%bound_N)
7743 if(
ASSOCIATED(domain%update_T))
then
7744 call deallocate_overlapspec(domain%update_T)
7745 deallocate(domain%update_T)
7748 if(
ASSOCIATED(domain%update_E))
then
7749 call deallocate_overlapspec(domain%update_E)
7750 deallocate(domain%update_E)
7753 if(
ASSOCIATED(domain%update_C))
then
7754 call deallocate_overlapspec(domain%update_C)
7755 deallocate(domain%update_C)
7758 if(
ASSOCIATED(domain%update_N))
then
7759 call deallocate_overlapspec(domain%update_N)
7760 deallocate(domain%update_N)
7763 end subroutine deallocate_domain2d_local
7767 subroutine allocate_check_overlap(overlap, count)
7768 type(overlap_type),
intent(inout) :: overlap
7769 integer,
intent(in ) :: count
7772 overlap%pe = null_pe
7773 if(
associated(overlap%tileMe))
call mpp_error(fatal, &
7774 "allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
7775 if(count < 1)
call mpp_error(fatal, &
7776 "allocate_check_overlap(mpp_domains_define): count should be a positive integer")
7777 allocate(overlap%tileMe (count), overlap%dir(count) )
7778 allocate(overlap%is (count), overlap%ie (count) )
7779 allocate(overlap%js (count), overlap%je (count) )
7780 allocate(overlap%rotation(count) )
7781 overlap%rotation = zero
7783 end subroutine allocate_check_overlap
7786 subroutine insert_check_overlap(overlap, pe, tileMe, dir, rotation, is, ie, js, je)
7787 type(overlap_type),
intent(inout) :: overlap
7788 integer,
intent(in ) :: pe
7789 integer,
intent(in ) :: tileMe, dir, rotation
7790 integer,
intent(in ) :: is, ie, js, je
7793 overlap%count = overlap%count + 1
7794 count = overlap%count
7795 if(.NOT.
associated(overlap%tileMe))
call mpp_error(fatal, &
7796 "mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
7797 if(count >
size(overlap%tileMe(:)) )
call mpp_error(fatal, &
7798 "mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
7799 if( overlap%pe == null_pe )
then
7802 if(overlap%pe .NE. pe)
call mpp_error(fatal, &
7803 "mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
7805 overlap%tileMe (count) = tileme
7806 overlap%dir (count) = dir
7807 overlap%rotation(count) = rotation
7808 overlap%is (count) = is
7809 overlap%ie (count) = ie
7810 overlap%js (count) = js
7811 overlap%je (count) = je
7813 end subroutine insert_check_overlap
7818 type(overlap_type),
intent(inout) :: overlap_out
7819 type(overlap_type),
intent(in ) :: overlap_in
7820 type(overlap_type) :: overlap
7821 integer :: count, count_in, count_out
7824 count_in = overlap_in %count
7825 count_out = overlap_out%count
7826 count = count_in+count_out
7827 if(count_in == 0)
call mpp_error(fatal, &
7828 "add_check_overlap(mpp_domains_define): overlap_in%count is zero")
7830 if(count_out == 0)
then
7831 if(
associated(overlap_out%tileMe))
call mpp_error(fatal, &
7832 "add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
7833 call allocate_check_overlap(overlap_out, count_in)
7834 overlap_out%pe = overlap_in%pe
7836 call allocate_check_overlap(overlap, count_out)
7837 if(overlap_out%pe .NE. overlap_in%pe)
call mpp_error(fatal, &
7838 "mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
7839 overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7840 overlap%is (1:count_out) = overlap_out%is (1:count_out)
7841 overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
7842 overlap%js (1:count_out) = overlap_out%js (1:count_out)
7843 overlap%je (1:count_out) = overlap_out%je (1:count_out)
7844 overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7845 overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7846 call deallocate_overlap_type(overlap_out)
7847 call allocate_check_overlap(overlap_out, count)
7848 overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7849 overlap_out%is (1:count_out) = overlap%is (1:count_out)
7850 overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
7851 overlap_out%js (1:count_out) = overlap%js (1:count_out)
7852 overlap_out%je (1:count_out) = overlap%je (1:count_out)
7853 overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7854 overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7855 call deallocate_overlap_type(overlap)
7857 overlap_out%count = count
7858 overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7859 overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
7860 overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
7861 overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
7862 overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
7863 overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7864 overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7869 subroutine init_overlap_type(overlap)
7870 type(overlap_type),
intent(inout) :: overlap
7873 overlap%pe = null_pe
7875 end subroutine init_overlap_type
7879 subroutine allocate_update_overlap( overlap, count)
7880 type(overlap_type),
intent(inout) :: overlap
7881 integer,
intent(in ) :: count
7884 overlap%pe = null_pe
7885 if(
associated(overlap%tileMe))
call mpp_error(fatal, &
7886 "allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
7887 if(count < 1)
call mpp_error(fatal, &
7888 "allocate_update_overlap(mpp_domains_define): count should be a positive integer")
7889 allocate(overlap%tileMe (count), overlap%tileNbr (count) )
7890 allocate(overlap%is (count), overlap%ie (count) )
7891 allocate(overlap%js (count), overlap%je (count) )
7892 allocate(overlap%dir (count), overlap%rotation(count) )
7893 allocate(overlap%from_contact(count), overlap%msgsize (count) )
7894 overlap%rotation = zero
7895 overlap%from_contact = .false.
7897 end subroutine allocate_update_overlap
7900 subroutine insert_update_overlap(overlap, pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir, reverse, symmetry)
7901 type(overlap_type),
intent(inout) :: overlap
7902 integer,
intent(in ) :: pe
7903 integer,
intent(in ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
7904 integer,
intent(in ) :: dir
7905 logical,
optional,
intent(in ) :: reverse, symmetry
7907 logical :: is_reverse, is_symmetry, is_overlapped
7908 integer :: is, ie, js, je, count
7910 is_reverse = .false.
7911 if(
PRESENT(reverse)) is_reverse = reverse
7912 is_symmetry = .false.
7913 if(
PRESENT(symmetry)) is_symmetry = symmetry
7915 is = max(is1,is2); ie = min(ie1,ie2)
7916 js = max(js1,js2); je = min(je1,je2)
7917 is_overlapped = .false.
7919 if(is_symmetry .AND. (dir == 1 .OR. dir == 5))
then
7920 if( ie .GE. is .AND. je .GT. js ) is_overlapped = .true.
7921 else if(is_symmetry .AND. (dir == 3 .OR. dir == 7))
then
7922 if( ie .GT. is .AND. je .GE. js ) is_overlapped = .true.
7923 else if(ie.GE.is .AND. je.GE.js )
then
7924 is_overlapped = .true.
7927 if(is_overlapped)
then
7928 if( overlap%count == 0 )
then
7931 if(overlap%pe .NE. pe)
call mpp_error(fatal, &
7932 "mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
7934 overlap%count = overlap%count+1
7935 count = overlap%count
7936 if(count > maxoverlap)
call mpp_error(fatal,
"mpp_domains_define.inc(insert_update_overlap):"//&
7937 &
" number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7938 overlap%is(count) = is
7939 overlap%ie(count) = ie
7940 overlap%js(count) = js
7941 overlap%je(count) = je
7942 overlap%tileMe (count) = 1
7943 overlap%tileNbr(count) = 1
7944 overlap%dir(count) = dir
7946 overlap%rotation(count) = one_hundred_eighty
7948 overlap%rotation(count) = zero
7952 end subroutine insert_update_overlap
7955 subroutine insert_overlap_type(overlap, pe, tileMe, tileNbr, is, ie, js, je, dir, &
7956 rotation, from_contact)
7957 type(overlap_type),
intent(inout) :: overlap
7958 integer,
intent(in ) :: tileMe, tileNbr, pe
7959 integer,
intent(in ) :: is, ie, js, je
7960 integer,
intent(in ) :: dir, rotation
7961 logical,
intent(in ) :: from_contact
7964 if( overlap%count == 0 )
then
7967 if(overlap%pe .NE. pe)
call mpp_error(fatal, &
7968 "mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
7970 overlap%count = overlap%count+1
7971 count = overlap%count
7972 if(count > maxoverlap)
call mpp_error(fatal,
"mpp_domains_define.inc(insert_overlap_type):"//&
7973 &
" number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7974 overlap%tileMe (count) = tileme
7975 overlap%tileNbr (count) = tilenbr
7976 overlap%is (count) = is
7977 overlap%ie (count) = ie
7978 overlap%js (count) = js
7979 overlap%je (count) = je
7980 overlap%dir (count) = dir
7981 overlap%rotation (count) = rotation
7982 overlap%from_contact(count) = from_contact
7983 overlap%msgsize (count) = (ie-is+1)*(je-js+1)
7985 end subroutine insert_overlap_type
7989 subroutine deallocate_overlap_type( overlap)
7990 type(overlap_type),
intent(inout) :: overlap
7992 if(overlap%count == 0)
then
7993 if( .NOT.
associated(overlap%tileMe))
return
7995 if( .NOT.
associated(overlap%tileMe))
call mpp_error(fatal, &
7996 "deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
7998 if(
ASSOCIATED(overlap%tileMe))
deallocate(overlap%tileMe)
7999 if(
ASSOCIATED(overlap%tileNbr))
deallocate(overlap%tileNbr)
8000 if(
ASSOCIATED(overlap%is))
deallocate(overlap%is)
8001 if(
ASSOCIATED(overlap%ie))
deallocate(overlap%ie)
8002 if(
ASSOCIATED(overlap%js))
deallocate(overlap%js)
8003 if(
ASSOCIATED(overlap%je))
deallocate(overlap%je)
8004 if(
ASSOCIATED(overlap%dir))
deallocate(overlap%dir)
8005 if(
ASSOCIATED(overlap%index))
deallocate(overlap%index)
8006 if(
ASSOCIATED(overlap%rotation))
deallocate(overlap%rotation)
8007 if(
ASSOCIATED(overlap%from_contact))
deallocate(overlap%from_contact)
8008 if(
ASSOCIATED(overlap%msgsize))
deallocate(overlap%msgsize)
8011 end subroutine deallocate_overlap_type
8014 subroutine deallocate_overlapspec(overlap)
8015 type(overlapspec),
intent(inout) :: overlap
8018 if(
ASSOCIATED(overlap%send))
then
8019 do n = 1,
size(overlap%send(:))
8020 call deallocate_overlap_type(overlap%send(n))
8022 deallocate(overlap%send)
8024 if(
ASSOCIATED(overlap%recv))
then
8025 do n = 1,
size(overlap%recv(:))
8026 call deallocate_overlap_type(overlap%recv(n))
8028 deallocate(overlap%recv)
8032 end subroutine deallocate_overlapspec
8036 subroutine add_update_overlap( overlap_out, overlap_in)
8037 type(overlap_type),
intent(inout) :: overlap_out
8038 type(overlap_type),
intent(in ) :: overlap_in
8039 type(overlap_type) :: overlap
8040 integer :: count, count_in, count_out, n
8043 count_in = overlap_in %count
8044 count_out = overlap_out%count
8045 count = count_in+count_out
8046 if(count_in == 0)
call mpp_error(fatal, &
8047 "mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
8049 if(count_out == 0)
then
8050 if(
associated(overlap_out%tileMe))
call mpp_error(fatal, &
8051 "mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
8052 call allocate_update_overlap(overlap_out, count_in)
8053 overlap_out%pe = overlap_in%pe
8055 if(overlap_in%pe .NE. overlap_out%pe)
call mpp_error(fatal, &
8056 "mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
8058 call allocate_update_overlap(overlap, count_out)
8059 overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
8060 overlap%tileNbr (1:count_out) = overlap_out%tileNbr (1:count_out)
8061 overlap%is (1:count_out) = overlap_out%is (1:count_out)
8062 overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
8063 overlap%js (1:count_out) = overlap_out%js (1:count_out)
8064 overlap%je (1:count_out) = overlap_out%je (1:count_out)
8065 overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
8066 overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
8067 overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
8068 call deallocate_overlap_type(overlap_out)
8069 call allocate_update_overlap(overlap_out, count)
8070 overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
8071 overlap_out%tileNbr (1:count_out) = overlap%tileNbr (1:count_out)
8072 overlap_out%is (1:count_out) = overlap%is (1:count_out)
8073 overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
8074 overlap_out%js (1:count_out) = overlap%js (1:count_out)
8075 overlap_out%je (1:count_out) = overlap%je (1:count_out)
8076 overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
8077 overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
8078 overlap_out%index (1:count_out) = overlap%index (1:count_out)
8079 overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
8080 overlap_out%msgsize (1:count_out) = overlap%msgsize (1:count_out)
8081 call deallocate_overlap_type(overlap)
8083 overlap_out%count = count
8084 overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
8085 overlap_out%tileNbr (count_out+1:count) = overlap_in%tileNbr (1:count_in)
8086 overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
8087 overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
8088 overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
8089 overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
8090 overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
8091 overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
8092 overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
8094 do n = count_out+1, count
8095 overlap_out%msgsize(n) = (overlap_out%ie(n)-overlap_out%is(n)+1)*(overlap_out%je(n)-overlap_out%js(n)+1)
8099 end subroutine add_update_overlap
8102 subroutine expand_update_overlap_list(overlapList, npes)
8103 type(overlap_type),
pointer :: overlapList(:)
8104 integer,
intent(in ) :: npes
8105 type(overlap_type),
pointer,
save :: newlist(:) => null()
8106 integer :: nlist_old, nlist, m
8108 nlist_old =
size(overlaplist(:))
8109 if(nlist_old .GE. npes)
call mpp_error(fatal, &
8110 'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
8111 nlist = min(npes, 2*nlist_old)
8112 allocate(newlist(nlist))
8114 call add_update_overlap(newlist(m), overlaplist(m))
8115 call deallocate_overlap_type(overlaplist(m))
8118 deallocate(overlaplist)
8119 overlaplist => newlist
8124 end subroutine expand_update_overlap_list
8127 subroutine expand_check_overlap_list(overlaplist, npes)
8128 type(overlap_type),
pointer :: overlaplist(:)
8129 integer,
intent(in) :: npes
8130 type(overlap_type),
pointer,
save :: newlist(:) => null()
8131 integer :: nlist_old, nlist, m
8133 nlist_old =
size(overlaplist(:))
8134 if(nlist_old .GE. npes)
call mpp_error(fatal, &
8135 'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
8136 nlist = min(npes, 2*nlist_old)
8137 allocate(newlist(nlist))
8138 do m = 1,
size(overlaplist(:))
8140 call deallocate_overlap_type(overlaplist(m))
8142 deallocate(overlaplist)
8143 overlaplist => newlist
8148 end subroutine expand_check_overlap_list
8152 subroutine check_overlap_pe_order(domain, overlap, name)
8153 type(domain2d),
intent(in) :: domain
8154 type(overlapspec),
intent(in) :: overlap
8155 character(len=*),
intent(in) :: name
8160 if( overlap%nsend > maxlist)
call mpp_error(fatal, &
8161 "mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
8162 if( overlap%nrecv > maxlist)
call mpp_error(fatal, &
8163 "mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
8165 do m = 2, overlap%nsend
8166 pe1 = overlap%send(m-1)%pe
8167 pe2 = overlap%send(m)%pe
8169 if( pe2 == domain%pe )
then
8170 print*, trim(name)//
" at pe = ", domain%pe,
": send pe is ", pe1, pe2
8171 call mpp_error(fatal, &
8172 "mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
8173 else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe))
then
8174 if( pe2 < pe1 )
then
8175 print*, trim(name)//
" at pe = ", domain%pe,
": send pe is ", pe1, pe2
8176 call mpp_error(fatal, &
8177 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
8179 else if ( pe2 > domain%pe .AND. pe1 < domain%pe )
then
8180 print*, trim(name)//
" at pe = ", domain%pe,
": send pe is ", pe1, pe2
8181 call mpp_error(fatal, &
8182 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
8187 do m = 2, overlap%nrecv
8188 pe1 = overlap%recv(m-1)%pe
8189 pe2 = overlap%recv(m)%pe
8191 if( pe2 == domain%pe )
then
8192 print*, trim(name)//
" at pe = ", domain%pe,
": recv pe is ", pe1, pe2
8193 call mpp_error(fatal, &
8194 "mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
8195 else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe))
then
8196 if( pe2 > pe1 )
then
8197 print*, trim(name)//
" at pe = ", domain%pe,
": recv pe is ", pe1, pe2
8198 call mpp_error(fatal, &
8199 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
8201 else if ( pe2 < domain%pe .AND. pe1 > domain%pe )
then
8202 print*, trim(name)//
" at pe = ", domain%pe,
": recv pe is ", pe1, pe2
8203 call mpp_error(fatal, &
8204 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
8209 end subroutine check_overlap_pe_order
8213 subroutine set_domain_comm_inf(update)
8214 type(overlapspec),
intent(inout) :: update
8216 integer :: m, totsize, n
8222 do m = 1, update%nrecv
8224 do n = 1, update%recv(m)%count
8225 totsize = totsize + update%recv(m)%msgsize(n)
8227 update%recv(m)%totsize = totsize
8229 update%recv(m)%start_pos = 0
8231 update%recv(m)%start_pos = update%recv(m-1)%start_pos + update%recv(m-1)%totsize
8233 update%recvsize = update%recvsize + totsize
8236 do m = 1, update%nsend
8238 do n = 1, update%send(m)%count
8239 totsize = totsize + update%send(m)%msgsize(n)
8241 update%send(m)%totsize = totsize
8243 update%send(m)%start_pos = 0
8245 update%send(m)%start_pos = update%send(m-1)%start_pos + update%send(m-1)%totsize
8247 update%sendsize = update%sendsize + totsize
8253 end subroutine set_domain_comm_inf
subroutine mpp_modify_domain2d(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, shalo, nhalo)
subroutine set_check_overlap(domain, position)
set up the overlapping for boundary check if the domain is symmetry. The check will be done on curren...
subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
add offset to the index
logical function mpp_mosaic_defined()
Accessor function for value of mosaic_defined.
subroutine set_contact_point(domain, position)
this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
subroutine mpp_define_domains1d(global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, memory_size, begin_halo, end_halo)
Define data and computational domains on a 1D set of data (isg:ieg) and assign them to PEs.
subroutine set_bound_overlap(domain, position)
set up the overlapping for boundary if the domain is symmetry.
subroutine define_contact_point(domain, position, num_contact, tile1, tile2, align1, align2, refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, isgList, iegList, jsgList, jegList)
compute the overlapping between tiles for the T-cell.
subroutine mpp_define_mosaic_pelist(sizes, pe_start, pe_end, pelist, costpertile)
Defines a pelist for use with mosaic tiles.
subroutine mpp_define_io_domain(domain, io_layout)
Define the layout for IO pe's for the given domain.
subroutine mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
Computes extents for a grid decomposition with the given indices and divisions.
subroutine mpp_modify_domain1d(domain_in, domain_out, cbegin, cend, gbegin, gend, hbegin, hend)
Modifies the exents of a domain.
subroutine compute_overlaps_fold_west(domain, position, ishift, jshift)
Computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine mpp_define_mosaic(global_indices, layout, domain, num_tile, num_contact, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, maskmap, name, memory_size, symmetry, xflags, yflags, tile_id)
Defines a domain for mosaic tile grids.
subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2)
always fill the contact according to index order.
subroutine mpp_define_layout2d(global_indices, ndivs, layout)
subroutine add_check_overlap(overlap_out, overlap_in)
this routine adds the overlap_in into overlap_out
subroutine mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend)
Computes the extents of a grid block.
subroutine compute_overlaps(domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, whalo, ehalo, shalo, nhalo)
Computes remote domain overlaps.
subroutine mpp_get_domain_shift(domain, ishift, jshift, position)
Returns the shift value in x and y-direction according to domain position..
subroutine compute_overlaps_fold_east(domain, position, ishift, jshift)
computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine compute_overlaps_fold_south(domain, position, ishift, jshift)
Computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
this routine sets up the overlapping for mpp_update_domains for arbitrary halo update....
subroutine mpp_define_domains2d(global_indices, layout, domain, pelist, xflags, yflags, xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset)
Define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,...
subroutine mpp_sync_self(pelist, check, request, msg_size, msg_type)
This is to check if current PE's outstanding puts are complete but we can't use shmem_fence because w...
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
subroutine mpp_declare_pelist(pelist, name, commID)
Declare a pelist.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.