4 !***********************************************************************
5 !* GNU Lesser General Public License
7 !* This file
is part of the GFDL Flexible Modeling System (FMS).
9 !* FMS
is free software: you can redistribute it and/or modify it under
10 !* the terms of the GNU Lesser General Public License as published by
11 !* the Free Software Foundation, either
version 3 of the License, or (at
12 !* your option) any later
version.
14 !* FMS
is distributed in the hope that it
will be useful, but WITHOUT
15 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 !* You should have
received a copy of the GNU Lesser General Public
20 !* License along with FMS. If
not, see <http:
21 !***********************************************************************
23 ! <SUBROUTINE NAME=
"mpp_define_layout2D" INTERFACE=
"mpp_define_layout">
24 ! <IN NAME=
"global_indices" TYPE=
"integer" DIM=
"(4)"></IN>
25 ! <IN NAME=
"ndivs" TYPE=
"integer"></IN>
26 ! <OUT NAME=
"layout" TYPE=
"integer" DIM=
"(2)"></OUT>
28 subroutine mpp_define_layout2D( global_indices, ndivs,
layout )
35 if(
size(global_indices(:)) .NE. 4) call
mpp_error(FATAL,
"mpp_define_layout2D: size of global_indices should be 4")
38 isg = global_indices(1)
39 ieg = global_indices(2)
40 jsg = global_indices(3)
41 jeg = global_indices(4)
45 !first try to
divide ndivs in the domain aspect ratio:
if imperfect aspect, reduce idiv till it divides ndivs
46 idiv = nint( sqrt(float(ndivs*isz)/jsz) )
47 idiv =
max(idiv,1) !for isz=1 line above can give 0
48 do while( mod(ndivs,idiv).NE.0 )
55 end subroutine mpp_define_layout2D
57 !############################################################################
58 ! <SUBROUTINE NAME=
"mpp_define_mosaic_pelist">
59 ! <IN NAME=
"global_indices" TYPE=
"integer" DIM=
"(4)"></IN>
60 ! <IN NAME=
"pelist" TYPE=
"integer" DIM=
"(0:)"> </IN>
62 ! NOTE: The following routine may need to revised to improve the capability.
63 ! It
is very hard to make it balance for all the situation.
64 ! Hopefully
some smart idea
will come
up someday.
65 subroutine mpp_define_mosaic_pelist( sizes, pe_start, pe_end,
pelist, costpertile)
73 integer :: cost_on_tile, cost_on_pe, npes_used, errunit
77 call
mpp_error(FATAL,
"mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
80 if(present(costpertile)) then
82 call
mpp_error(FATAL,
"mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
84 costs = sizes*costpertile
90 if( .NOT.any(
pelist.EQ.mpp_pe()) )then
92 write( errunit,* )
'pe=', mpp_pe(),
' pelist=',
pelist 93 call
mpp_error( FATAL,
'mpp_define_mosaic_pelist: pe must be in pelist.' )
96 allocate( pes(0:
npes-1) )
100 allocate( pes(0:
npes-1) )
101 call mpp_get_current_pelist(pes)
108 do while( ntiles_left > 0 )
109 if( npes_left == 1 ) then ! all
left tiles
will on the
last processor, imbalance possibly.
111 if(costs(
n) > 0) then
120 totcosts = sum(costs)
121 avgcost = CEILING(real(totcosts)/npes_left )
122 tile = minval(maxloc(costs))
123 cost_on_tile = costs(
tile)
125 ntiles_left = ntiles_left - 1
127 totcosts = totcosts - cost_on_tile
128 if(cost_on_tile .GE. avgcost ) then
129 npes_used =
min(ceiling(real(cost_on_tile)/avgcost), npes_left)
130 if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
131 pe_end(
tile) =
pos + npes_used - 1
132 npes_left = npes_left - npes_used
135 !--- find other tiles to share the
pe 137 cost_on_pe = cost_on_tile
138 do while(ntiles_left>npes_left) ! make sure all the pes are used.
139 tile = minval(minloc(costs, costs> 0 ))
140 cost_on_tile = costs(
tile)
141 cost_on_pe = cost_on_pe + cost_on_tile
142 if(cost_on_pe > avgcost ) exit
145 ntiles_left = ntiles_left - 1
147 totcosts = totcosts - cost_on_tile
149 npes_left = npes_left - 1
155 if(npes_left .NE. 0 ) call
mpp_error(FATAL,
"mpp_define_mosaic_pelist: the left npes should be zero")
158 end subroutine mpp_define_mosaic_pelist
160 !-- The following implementation
is different from mpp_compute_extents
161 !-- The
last block might have most points
162 subroutine mpp_compute_block_extent(
isg,
ieg,ndivs,ibegin,iend)
171 !domain
is sized by dividing remaining points by remaining domains
172 is =
ie - CEILING( REAL(
ie-
isg+1)/ndiv ) + 1
177 'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
178 if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE.
isg ) &
179 call
mpp_error( FATAL,
'mpp_compute_block_extent: domain extents do not span space completely.' )
183 end subroutine mpp_compute_block_extent
186 !#####################################################################
187 subroutine mpp_compute_extent(
isg,
ieg,ndivs,ibegin,iend, extent )
192 integer :: ndiv, imax, ndmax, ndmirror
194 logical :: symmetrize, use_extent
197 even(
n) = (mod(
n,2).EQ.0)
198 odd (
n) = (mod(
n,2).EQ.1)
201 if(PRESENT(extent)) then
202 if(
size(extent(:)).NE.ndivs ) &
203 call
mpp_error( FATAL,
'mpp_compute_extent: extent array size must equal number of domain divisions.' )
205 if(ALL(extent ==0)) use_extent = .
false.
212 if(extent(ndiv) .LE. 0) call
mpp_error( FATAL,
'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,
'mpp_compute_extent: extent array limits do not match global domain.' )
220 !modified for mirror-symmetry
222 !
ie =
is + CEILING( float(
ieg-
is+1)/(ndivs-ndiv) ) - 1
224 !problem of dividing
nx points into
n domains maintaining symmetry
225 !
i.
e nx=18
n=4 4554 and 5445 are solutions but 4455
is not.
226 !this
will always work for
nx even
n even or odd
227 !this
will always work for
nx odd,
n odd
228 !this
will never work for
nx odd,
n even: for this
case we supersede the mirror calculation
229 ! symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(
ieg-
isg+1,2).EQ.1 )
231 symmetrize = ( even(ndivs) .AND. even(
ieg-
isg+1) ) .OR. &
232 ( odd(ndivs) .AND. odd(
ieg-
isg+1) ) .OR. &
233 ( odd(ndivs) .AND. even(
ieg-
isg+1) .AND. ndivs.LT.(
ieg-
isg+1)/2 )
235 !mirror domains are stored in the list and retrieved
if required.
241 !do bottom
half of decomposition, going over the midpoint for odd ndivs
242 if( ndiv.LT.(ndivs-1)/2+1 )then
243 !domain
is sized by dividing remaining points by remaining domains
244 ie =
is + CEILING( REAL(imax-
is+1)/(ndmax-ndiv) ) - 1
245 ndmirror = (ndivs-1) - ndiv !mirror domain
246 if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
247 !mirror extents, the
max(,)
is to eliminate overlaps
250 imax = ibegin(ndmirror) - 1
255 !do top
half of decomposition by retrieving saved values
259 ie =
is + CEILING( REAL(imax-
is+1)/(ndmax-ndiv) ) - 1
265 'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
266 if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.
ieg ) &
267 call
mpp_error( FATAL,
'mpp_compute_extent: domain extents do not span space completely.' )
273 end subroutine mpp_compute_extent
275 !#####################################################################
277 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
279 ! MPP_DEFINE_DOMAINS: define
layout and decomposition !
281 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
283 ! <SUBROUTINE NAME=
"mpp_define_domains1D" INTERFACE=
"mpp_define_domains">>
284 ! <IN NAME=
"global_indices" TYPE=
"integer" DIM=
"(2)"> </IN>
285 ! <IN NAME=
"ndivs" TYPE=
"integer"> </IN>
286 ! <INOUT NAME=
"domain" TYPE=
"type(domain1D)"> </INOUT>
287 ! <IN NAME=
"pelist" TYPE=
"integer" DIM=
"(0:)"> </IN>
288 ! <IN NAME=
"flags" TYPE=
"integer"> </IN>
289 ! <IN NAME=
"halo" TYPE=
"integer"> </IN>
290 ! <IN NAME=
"extent" TYPE=
"integer" DIM=
"(0:)"> </IN>
291 ! <IN NAME=
"maskmap" TYPE=
"logical" DIM=
"(0:)"> </IN>
293 !routine to
divide global array indices among domains, and assign domains to PEs
294 !domain
is of
type domain1D
296 ! global_indices(2)=(
isg,
ieg) gives the extent of
global domain
297 ! ndivs
is number of divisions of domain: even divisions unless extent
is present.
298 ! domain
is the returned domain1D
299 !
pelist (optional) list of PEs to which domains are to be assigned (default 0...
npes-1)
300 !
size of
pelist must correspond to number of mask=.TRUE. divisions
301 ! flags define whether compute and data domains are
global (undecomposed) and whether
global domain has periodic boundaries
302 ! halo (optional) defines halo width (currently the same on both sides)
303 ! extent (optional) array defines width of each division (used for non-uniform domain decomp, for
e.
g load-balancing)
304 ! maskmap (optional)
a division whose maskmap=.FALSE.
is not assigned to any domain
305 ! By default we assume decomposition of compute and data domains, non-periodic boundaries,
no halo, as close to uniform extents
306 ! as the input parameters permit
307 subroutine mpp_define_domains1D( global_indices, ndivs, domain,
pelist, flags, halo, extent, maskmap, &
308 memory_size, begin_halo, end_halo )
311 type(domain1D), intent(inout) :: domain !declared inout so that existing links,
if any, can be nullified
313 integer, intent(in), optional :: flags, halo
314 integer, intent(in), optional :: extent(0:)
315 logical, intent(in), optional :: maskmap(0:)
316 integer, intent(in), optional :: memory_size
317 integer, intent(in), optional :: begin_halo, end_halo
319 logical :: compute_domain_is_global, data_domain_is_global
322 integer :: ibegin(0:ndivs-1), iend(0:ndivs-1)
323 logical :: mask(0:ndivs-1)
324 integer :: halosz, halobegin, haloend
328 if(
size(global_indices(:)) .NE. 2) call
mpp_error(FATAL,
"mpp_define_domains1D: size of global_indices should be 2")
330 isg = global_indices(1)
331 ieg = global_indices(2)
332 if( ndivs.GT.
ieg-
isg+1 )call
mpp_error( FATAL,
'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
333 !get the list of PEs on which to assign domains;
if pelist is absent use 0..
npes-1
335 if( .NOT.any(
pelist.EQ.mpp_pe()) )then
343 allocate( pes(0:mpp_npes()-1) )
344 call mpp_get_current_pelist(pes)
345 ! pes(:) = (/ (
i,
i=0,mpp_npes()-1) /)
348 !get number of real domains: 1 mask domain
per PE in pes
349 mask = .TRUE. !default mask
350 if( PRESENT(maskmap) )then
351 if(
size(maskmap(:)).NE.ndivs ) &
352 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: maskmap array
size must
equal number of domain divisions.' )
355 if( count(mask).NE.
size(pes(:)) ) &
356 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match
PE count.' )
360 if( PRESENT(halo) ) then
362 !---
if halo
is present, begin_halo and end_halo should
not present
363 if(present(begin_halo) .OR. present(end_halo) ) call
mpp_error(FATAL, &
364 "mpp_domains_define.inc: when halo
is present, begin_halo and end_halo should
not present")
366 halobegin = halosz; haloend = halosz
367 if(present(begin_halo)) halobegin = begin_halo
368 if(present(end_halo)) haloend = end_halo
369 halosz =
max(halobegin, haloend)
371 compute_domain_is_global = .FALSE.
372 data_domain_is_global = .FALSE.
376 if( PRESENT(flags) )then
377 !NEW: obsolete flag global_compute_domain, since ndivs
is non-optional and you cannot have
global compute and ndivs.NE.1
378 compute_domain_is_global = ndivs.EQ.1
379 !
if compute domain
is global, data domain must also be
380 data_domain_is_global = BTEST(flags,GLOBAL) .OR. compute_domain_is_global
381 domain%
cyclic = BTEST(flags,CYCLIC) .AND. halosz.NE.0
382 if(BTEST(flags,CYCLIC)) domain%goffset = 0
386 allocate( domain%list(0:ndivs-1) )
393 domain%list(:)%
global%is_global = .TRUE. !always
396 if( compute_domain_is_global )then
398 domain%list(:)%compute%
end =
ieg 399 domain%list(:)%compute%is_global = .TRUE.
400 domain%list(:)%
pe = pes(:)
403 domain%list(:)%compute%is_global = .FALSE.
405 call mpp_compute_extent(
isg,
ieg, ndivs, ibegin, iend, extent)
407 domain%list(ndiv)%compute%
begin = ibegin(ndiv)
408 domain%list(ndiv)%compute%
end = iend(ndiv)
410 domain%list(ndiv)%
pe = pes(
n)
411 if( mpp_pe().EQ.pes(
n) )domain%
pos = ndiv
414 domain%list(ndiv)%
pe = NULL_PE
419 domain%list(:)%compute%
size = domain%list(:)%compute%
end - domain%list(:)%compute%
begin + 1
422 !data domain
is at least
equal to compute domain
423 domain%list(:)%data%
begin = domain%list(:)%compute%
begin 424 domain%list(:)%data%
end = domain%list(:)%compute%
end 425 domain%list(:)%data%is_global = .FALSE.
427 if( data_domain_is_global )then
429 domain%list(:)%data%
end =
ieg 430 domain%list(:)%data%is_global = .TRUE.
433 domain%list(:)%data%
begin = domain%list(:)%data%
begin - halobegin
434 domain%list(:)%data%
end = domain%list(:)%data%
end + haloend
435 domain%list(:)%data%
size = domain%list(:)%data%
end - domain%list(:)%data%
begin + 1
437 !--- define memory domain,
if memory_size
is not present or memory
size is 0, memory domain
size 438 !---
will be the same as data domain
size.
if momory_size
is present, memory_size should greater than
439 !--- or
equal to data
size. The
begin of memory domain
will be always the same as data domain.
440 domain%list(:)%memory%
begin = domain%list(:)%data%
begin 441 domain%list(:)%memory%
end = domain%list(:)%data%
end 442 if( present(memory_size) ) then
443 if(memory_size > 0) then
445 "mpp_domains_define.inc: data domain
size is larger than memory domain
size on this
pe")
446 domain%list(:)%memory%
end = domain%list(:)%memory%
begin + memory_size - 1
449 domain%list(:)%memory%
size = domain%list(:)%memory%
end - domain%list(:)%memory%
begin + 1
450 domain%list(:)%memory%is_global = domain%list(:)%data%is_global
452 domain%compute = domain%list(domain%
pos)%compute
453 domain%data = domain%list(domain%
pos)%data
455 domain%memory = domain%list(domain%
pos)%memory
456 domain%compute%max_size = MAXVAL( domain%list(:)%compute%
size )
457 domain%data%max_size = MAXVAL( domain%list(:)%data%
size )
459 domain%memory%max_size = domain%memory%
size 461 !PV786667: the deallocate stmts can be removed when fixed (7.3.1.3
m)
465 end subroutine mpp_define_domains1D
467 !
################################################################################ 468 !--- define the IO domain.
469 subroutine mpp_define_io_domain(domain,
io_layout)
470 type(domain2D), intent(inout) :: domain
474 type(domain2D), pointer :: io_domain=>
NULL()
476 integer :: ipos, jpos, igroup, jgroup
477 integer :: ipos_beg, ipos_end, jpos_beg, jpos_end
478 integer :: whalo, ehalo, shalo, nhalo
484 "mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for " 485 " when one or both entry of io_layout is not positive")
492 if(ASSOCIATED(domain%io_domain)) call
mpp_error(FATAL, &
493 "mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
496 "mpp_domains_define.inc(mpp_define_io_domain): " 498 "mpp_domains_define.inc(mpp_define_io_domain): " 500 "mpp_domains_define.inc(mpp_define_io_domain): " 501 ": multiple tile per pe is not supported yet for this routine")
503 allocate(domain%io_domain)
505 io_domain => domain%io_domain
506 ! Find how many processors are in the group with the consideration that
some of the region maybe masked
out.
513 ipos_beg = igroup*
npes_x; ipos_end = ipos_beg +
npes_x - 1
514 jpos_beg = jgroup*
npes_y; jpos_end = jpos_beg +
npes_y - 1
516 do j = jpos_beg, jpos_end
517 do i = ipos_beg, ipos_end
518 if(domain%pearray(
i,
j) .NE. NULL_PE) npes_in_group = npes_in_group+1
522 io_domain%whalo = domain%whalo
523 io_domain%ehalo = domain%ehalo
524 io_domain%shalo = domain%shalo
525 io_domain%nhalo = domain%nhalo
527 io_domain%
pe = domain%
pe 528 io_domain%symmetry = domain%symmetry
529 allocate(io_domain%list(0:npes_in_group-1))
530 do
i = 0, npes_in_group-1
531 allocate( io_domain%list(
i)%x(1), io_domain%list(
i)%y(1), io_domain%list(
i)%tile_id(1) )
534 ndivx =
size(domain%pearray,1)
535 ndivy =
size(domain%pearray,2)
536 allocate(posarray(0:ndivx-1, 0:ndivy-1))
537 n = domain%tile_root_pe - mpp_root_pe()
541 if( domain%pearray(
i,
j) == NULL_PE) cycle
548 do
j = jpos_beg, jpos_end
549 do
i = ipos_beg, ipos_end
550 if( domain%pearray(
i,
j) == NULL_PE) cycle
551 io_domain%list(
n)%
pe = domain%pearray(
i,
j)
553 io_domain%list(
n)%x(1)%compute = domain%list(
m)%x(1)%compute
554 io_domain%list(
n)%y(1)%compute = domain%list(
m)%y(1)%compute
557 io_domain%list(
n)%tile_id(1) = jgroup*
io_layout(1) + igroup
563 allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
564 allocate(io_domain%x(1)%list(0:
npes_x-1), io_domain%y(1)%list(0:
npes_y-1) )
566 do
j = jpos_beg, jpos_beg+jpos
567 do
i = ipos_beg, ipos_beg+ipos
568 if(domain%pearray(
i,
j) .NE. NULL_PE)
n =
n + 1
572 io_domain%x(1)%compute = domain%x(1)%compute
573 io_domain%x(1)%data = domain%x(1)%data
574 io_domain%x(1)%memory = domain%x(1)%memory
575 io_domain%y(1)%compute = domain%y(1)%compute
576 io_domain%y(1)%data = domain%y(1)%data
577 io_domain%y(1)%memory = domain%y(1)%memory
579 io_domain%x(1)%
global%
end = domain%x(1)%list(ipos_end)%compute%
end 583 io_domain%y(1)%
global%
end = domain%y(1)%list(jpos_end)%compute%
end 586 io_domain%x(1)%
pos = ipos
587 io_domain%y(1)%
pos = jpos
588 io_domain%tile_id(1) = io_domain%list(
n)%tile_id(1)
589 io_domain%tile_root_pe = io_domain%list(0)%
pe 594 !!$ io_domain%y(1)%list(
j) = io_domain%list(
n)%y(1)
598 !!$ io_domain%x(1)%list(
i) = io_domain%list(
n)%x(1)
609 end subroutine mpp_define_io_domain
611 ! <SUBROUTINE NAME="mpp_define_domains2D" INTERFACE="mpp_define_domains">
612 ! <IN NAME="global_indices" TYPE="
integer" DIM="(4)"> </IN>
614 ! <INOUT NAME="domain" TYPE="
type(domain2D)"></INOUT>
616 ! <IN NAME="xflags, yflags" TYPE="
integer"></IN>
617 ! <IN NAME="xhalo, yhalo" TYPE="
integer"></IN>
618 ! <IN NAME="xextent, yextent" TYPE="
integer" DIM="(0:)"></IN>
619 ! <IN NAME="maskmap" TYPE="logical" DIM="(:,:)"></IN>
620 ! <IN NAME="
name" TYPE="character(
len=*)"></IN>
622 subroutine mpp_define_domains2D( global_indices,
layout, domain,
pelist, xflags, yflags, &
623 xhalo, yhalo, xextent, yextent, maskmap,
name, symmetry, memory_size, &
624 whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
625 !define 2D data and computational domain on
global rectilinear cartesian domain (
isg:
ieg,
jsg:
jeg) and assign them to PEs
628 type(domain2D), intent(inout) :: domain
630 integer, intent(in), optional :: xflags, yflags, xhalo, yhalo
631 integer, intent(in), optional :: xextent(0:), yextent(0:)
632 logical, intent(in), optional :: maskmap(0:,0:)
633 character(
len=*), intent(in), optional ::
name 634 logical, intent(in), optional :: symmetry
635 logical, intent(in), optional :: is_mosaic ! indicate
if calling mpp_define_domains from mpp_define_mosaic.
636 integer, intent(in), optional :: memory_size(:)
637 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! halo
size for West, East, South and North direction.
638 !
if whalo and ehalo
is not present,
639 !
will take the value of xhalo
640 !
if shalo and nhalo
is not present,
641 !
will take the value of yhalo
642 integer, intent(in), optional :: tile_count !
tile number on current
pe, default value
is 1
643 ! this
is for the situation that multiple tiles on
one processor.
645 logical, intent(in), optional :: complete !
true indicate mpp_define_domain
is completed for mosaic definition.
647 ! (0,
j) = (ni, mod(
j+x_cyclic_offset,nj))
648 ! (ni+1,
j) = ( 1, mod(
j+nj-x_cyclic_offset,nj) )
650 ! (
i,0) = (mod(
i+y_cyclic_offset,ni), nj))
651 ! (
i,nj+1) = (mod(mod(
i+ni-y_cyclic_offset,ni), 1) )
653 integer ::
i,
j,
m,
n, xhalosz, yhalosz, memory_xsize, memory_ysize
654 integer :: whalosz, ehalosz, shalosz, nhalosz
657 integer :: x_offset, y_offset, start_pos, nfold
658 logical :: from_mosaic, is_complete
665 type(overlapSpec), pointer :: update=>
NULL()
666 type(overlapSpec), pointer :: check_T =>
NULL()
667 character(
len=1) :: position
676 "mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument
name ="
677 "
is greater than NAME_LENGTH, change the argument
name or increase NAME_LENGTH")
681 "mpp_define_domains2D:
size of global_indices should be 4 for "
685 isg = global_indices(1);
ieg = global_indices(2);
jsg = global_indices(3);
jeg = global_indices(4)
687 from_mosaic = .
false.
688 if(present(is_mosaic)) from_mosaic = is_mosaic
690 if(present(complete)) is_complete = complete
692 if(present(tile_count))
tile = tile_count
694 if(present(tile_id)) cur_tile_id = tile_id
700 allocate( pesall(0:mpp_npes()-1) )
701 call mpp_get_current_pelist(pesall)
703 allocate( pesall(0:
size(pes(:))-1) )
707 allocate( pes(0:mpp_npes()-1) )
708 allocate( pesall(0:mpp_npes()-1) )
709 call mpp_get_current_pelist(pes)
713 !--- at least of
one of x_cyclic_offset and y_cyclic_offset must be
zero 714 !--- folded boundary condition
is not supported when either x_cyclic_offset or y_cyclic_offset
is nonzero.
715 !--- Since we only implemented Folded-
north boundary condition currently, we only consider y-flags.
716 x_offset = 0; y_offset = 0
717 if(PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
718 if(PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
719 if(x_offset*y_offset .NE. 0) call
mpp_error(FATAL, &
720 'MPP_DEFINE_DOMAINS2D: At least
one of x_cyclic_offset and y_cyclic_offset must be
zero for '
722 !--- x_cyclic_offset and y_cyclic_offset should
no larger than the
global grid
size.
724 'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset
is greater than
jeg-
jsg+1 for '
726 'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset
is greater than
ieg-
isg+1 for '
728 !--- when there
is more than
one tile on
one processor, all the
tile will limited on this processor
730 'MPP_DEFINE_DOMAINS2D: there are more than
one tile on this
pe, '
731 'all the
tile should be limited on this
pe for '
733 !--- the position of current
pe is changed due to mosaic, because pes
734 !---
is only part of the
pelist in mosaic (pesall). We assume the
pe 735 !--- distribution are contious in mosaic.
737 do
n = 0,
size(pesall(:))-1
738 if(pesall(
n) == mpp_pe() ) then
743 if(
pos<0) call
mpp_error(FATAL, 'MPP_DEFINE_DOMAINS2D: mpp_pe()
is not in the pesall list')
745 domain%symmetry = .FALSE.
746 if(present(symmetry)) domain%symmetry = symmetry
747 if(domain%symmetry) then
748 ishift = 1; jshift = 1
750 ishift = 0; jshift = 0
753 !--- first compute domain decomposition.
754 call mpp_compute_extent(
isg,
ieg, ndivx, ibegin, iend, xextent)
755 call mpp_compute_extent(
jsg,
jeg, ndivy, jbegin,
jend, yextent)
757 xhalosz = 0; yhalosz = 0
758 if(present(xhalo)) xhalosz = xhalo
759 if(present(yhalo)) yhalosz = yhalo
760 whalosz = xhalosz; ehalosz = xhalosz
761 shalosz = yhalosz; nhalosz = yhalosz
762 if(present(whalo)) whalosz = whalo
763 if(present(ehalo)) ehalosz = ehalo
764 if(present(shalo)) shalosz = shalo
765 if(present(nhalo)) nhalosz = nhalo
767 !--- configure maskmap
769 if( PRESENT(maskmap) )then
770 if(
size(maskmap,1).NE.ndivx .OR.
size(maskmap,2).NE.ndivy ) &
771 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: maskmap array does
not match
layout for '
772 mask(:,:) = maskmap(:,:)
774 !number of unmask domains in
layout must
equal number of PEs assigned
777 write(
text,'(i8)' )
n 778 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for '
779 'this
layout and maskmap. Use '
782 memory_xsize = 0; memory_ysize = 0
783 if(present(memory_size)) then
785 "mpp_define_domains2D:
size of memory_size should be 2 for "
786 memory_xsize = memory_size(1)
787 memory_ysize = memory_size(2)
790 !---
set up domain%list.
791 !---
set up 2-D domain decomposition for
T, E, C, N and computing overlapping
793 nlist =
size(pesall(:))
794 if( .NOT. Associated(domain%x) ) then
795 allocate(domain%tileList(1))
796 domain%tileList(1)%xbegin = global_indices(1)
797 domain%tileList(1)%xend = global_indices(2)
798 domain%tileList(1)%ybegin = global_indices(3)
799 domain%tileList(1)%yend = global_indices(4)
800 allocate(domain%x(1), domain%y(1) )
801 allocate(domain%tile_id(1))
802 domain%tile_id = cur_tile_id
804 domain%max_ntile_pe = 1
806 domain%rotated_ninety = .FALSE.
807 allocate( domain%list(0:nlist-1) )
809 allocate( domain%list(
i)%x(1), domain%list(
i)%y(1), domain%list(
i)%tile_id(1) )
813 domain%initialized = .
true.
817 if(pesall(
n) == pes(0)) then
823 !place on
PE array; need flag to assign them to
j first and then
i 824 pearray(:,:) = NULL_PE
825 ipos = NULL_PE; jpos = NULL_PE
831 pearray(
i,
j) = pes(
n)
833 domain%list(
m)%x(
tile)%compute%
end = iend(
i)
838 domain%list(
m)%tile_id(
tile) = cur_tile_id
841 domain%list(
m)%tile_root_pe = pes(0)
842 domain%list(
m)%
pe = pesall(
m)
844 if( pes(
n).EQ.mpp_pe() )then
854 !Considering mosaic, the following
will only be done on the
pe in the
pelist 856 if( ANY(pes == mpp_pe()) ) then
858 domain%tile_root_pe = pes(0)
859 if( ipos.EQ.NULL_PE .OR. jpos.EQ.NULL_PE ) &
863 write( errunit, * )'
pe,
tile, ipos, jpos=', mpp_pe(),
tile, ipos, jpos, ' pearray(:,jpos)=', &
864 pearray(:,jpos), ' pearray(ipos,:)=', pearray(ipos,:)
869 allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
870 domain%pearray = pearray
878 !do domain decomposition using 1D versions in X and Y,
879 call mpp_define_domains( global_indices(1:2), ndivx, domain%x(
tile), &
880 pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
881 call mpp_define_domains( global_indices(3:4), ndivy, domain%y(
tile), &
882 pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
883 if( domain%x(
tile)%list(ipos)%
pe.NE.domain%y(
tile)%list(jpos)%
pe ) &
884 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%
pe.NE.domain%y%list(jpos)%
pe.' )
886 !--- when x_cyclic_offset or y_cyclic_offset
is set,
no cross domain
is allowed
887 if(x_offset .NE. 0 .OR. y_offset .NE. 0) then
888 if(whalosz .GT. domain%x(
tile)%compute%
size .OR. ehalosz .GT. domain%x(
tile)%compute%
size ) &
889 call
mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset
is set, "
890 "whalo and ehalo must be
no larger than the x-direction computation domain
size")
891 if(shalosz .GT. domain%y(
tile)%compute%
size .OR. nhalosz .GT. domain%y(
tile)%compute%
size ) &
892 call
mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset
is set, "
893 "shalo and nhalo must be
no larger than the y-direction computation domain
size")
909 if( PRESENT(xflags) )then
910 if( BTEST(xflags,WEST) ) then
911 !--- make sure
no cross-domain in y-direction
915 'MPP_DEFINE_DOMAINS: the domain could
not be crossed when
west is folded')
918 'MPP_DEFINE_DOMAINS: an axis cannot be both folded
west and
cyclic for '
919 domain%fold = domain%fold + FOLD_WEST_EDGE
922 if( BTEST(xflags,EAST) ) then
923 !--- make sure
no cross-domain in y-direction
927 'MPP_DEFINE_DOMAINS: the domain could
not be crossed when
north is folded')
930 'MPP_DEFINE_DOMAINS: an axis cannot be both folded
east and
cyclic for '
931 domain%fold = domain%fold + FOLD_EAST_EDGE
935 if( PRESENT(yflags) )then
936 if( BTEST(yflags,SOUTH) ) then
937 !--- make sure
no cross-domain in y-direction
941 'MPP_DEFINE_DOMAINS: the domain could
not be crossed when
south is folded')
944 'MPP_DEFINE_DOMAINS: an axis cannot be both folded
north and
cyclic for '
945 domain%fold = domain%fold + FOLD_SOUTH_EDGE
948 if( BTEST(yflags,NORTH) ) then
949 !--- when the halo
size is big and halo region
is crossing neighbor domain, we
966 'MPP_DEFINE_DOMAINS: an axis cannot be both folded
south and
cyclic for '
967 domain%fold = domain%fold + FOLD_NORTH_EDGE
972 'MPP_DEFINE_DOMAINS2D: number of folded edge
is greater than 1 for '
975 if( x_offset .NE. 0 .OR. y_offset .NE. 0) call
mpp_error(FATAL, &
976 'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition, '
977 'x_cyclic_offset and y_cyclic_offset must be
zero for '
979 if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,NORTH) )then
981 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and
cyclic for '
983 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in X must be even '
984 'when there
is a fold in Y for '
985 !
check if folded domain boundaries line
up in X: compute domains lining
up is a sufficient condition for symmetry
989 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries '
990 'must line
up (mirror-symmetric extents) for '
993 if( BTEST(domain%fold,WEST) .OR. BTEST(domain%fold,EAST) )then
995 'MPP_DEFINE_DOMAINS: an axis cannot be both folded and
cyclic for '
997 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in Y must be even '
998 'when there
is a fold in X for '
999 !
check if folded domain boundaries line
up in Y: compute domains lining
up is a sufficient condition for symmetry
1003 call
mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must '
1004 'line
up (mirror-symmetric extents) for '
1009 if( mpp_pe().EQ.pes(0) .AND. PRESENT(
name) )then
1011 write( logunit, '(/
a,i5,
a,i5)' )trim(
name)
1012 write( logunit, '(3x,
a)' )'
pe,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed'
1014 end if !
if( ANY(pes == mpp_pe()) )
1016 if(is_complete) then
1017 domain%whalo = whalosz; domain%ehalo = ehalosz
1018 domain%shalo = shalosz; domain%nhalo = nhalosz
1019 allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
1020 domain%update_T%next =>
NULL()
1021 domain%update_E%next =>
NULL()
1022 domain%update_C%next =>
NULL()
1023 domain%update_N%next =>
NULL()
1024 allocate(domain%check_E, domain%check_C, domain%check_N )
1025 domain%update_T%nsend = 0
1026 domain%update_T%nrecv = 0
1027 domain%update_C%nsend = 0
1028 domain%update_C%nrecv = 0
1029 domain%update_E%nsend = 0
1030 domain%update_E%nrecv = 0
1031 domain%update_N%nsend = 0
1032 domain%update_N%nrecv = 0
1034 if( BTEST(domain%fold,SOUTH) ) then
1035 call compute_overlaps_fold_south(domain, CENTER, 0, 0)
1036 call compute_overlaps_fold_south(domain, CORNER, ishift, jshift)
1037 call compute_overlaps_fold_south(domain, EAST, ishift, 0)
1038 call compute_overlaps_fold_south(domain, NORTH, 0, jshift)
1039 else
if( BTEST(domain%fold,WEST) ) then
1040 call compute_overlaps_fold_west(domain, CENTER, 0, 0)
1041 call compute_overlaps_fold_west(domain, CORNER, ishift, jshift)
1042 call compute_overlaps_fold_west(domain, EAST, ishift, 0)
1043 call compute_overlaps_fold_west(domain, NORTH, 0, jshift)
1044 else
if( BTEST(domain%fold,EAST) ) then
1045 call compute_overlaps_fold_east(domain, CENTER, 0, 0)
1046 call compute_overlaps_fold_east(domain, CORNER, ishift, jshift)
1047 call compute_overlaps_fold_east(domain, EAST, ishift, 0)
1048 call compute_overlaps_fold_east(domain, NORTH, 0, jshift)
1050 call compute_overlaps(domain, CENTER, domain%update_T, check_T, 0, 0, x_offset, y_offset, &
1051 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1052 call compute_overlaps(domain, CORNER, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
1053 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1054 call compute_overlaps(domain, EAST, domain%update_E, domain%check_E, ishift, 0, x_offset, y_offset, &
1055 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1056 call compute_overlaps(domain, NORTH, domain%update_N, domain%check_N, 0, jshift, x_offset, y_offset, &
1057 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1059 call check_overlap_pe_order(domain, domain%update_T, trim(domain%
name)
1060 call check_overlap_pe_order(domain, domain%update_C, trim(domain%
name)
1061 call check_overlap_pe_order(domain, domain%update_E, trim(domain%
name)
1062 call check_overlap_pe_order(domain, domain%update_N, trim(domain%
name)
1065 !--- when ncontacts
is nonzero, set_check_overlap
will be called in mpp_define
1066 if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%
ntiles == 1) ) then
1067 call set_check_overlap( domain, CORNER )
1068 call set_check_overlap( domain, EAST )
1069 call set_check_overlap( domain, NORTH )
1070 allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1071 call set_bound_overlap( domain, CORNER )
1072 call set_bound_overlap( domain, EAST )
1073 call set_bound_overlap( domain, NORTH )
1075 call set_domain_comm_inf(domain%update_T)
1076 call set_domain_comm_inf(domain%update_E)
1077 call set_domain_comm_inf(domain%update_C)
1078 call set_domain_comm_inf(domain%update_N)
1083 !--- the
check will be done in mpp_define_mosaic
1087 call check_message_size(domain, domain%update_T,
send,
recv, '
T')
1088 call check_message_size(domain, domain%update_E,
send,
recv, 'E')
1089 call check_message_size(domain, domain%update_C,
send,
recv, 'C')
1090 call check_message_size(domain, domain%update_N,
send,
recv, 'N')
1094 !print
out decomposition, this didn'
t consider maskmap.
1095 if( mpp_pe() .EQ. pes(0) .AND. PRESENT(
name) )then
1096 write(*,*) trim(
name)
1097 write(*,'(
a,i4,
a,i4,
a,i4,
a,i4)')'whalo = ', whalosz, ", ehalo = ", ehalosz, ", shalo = ", shalosz, ", nhalo = ", nhalosz
1098 write (*,110) (domain%x(1)%list(
i)%compute%
size,
i= 0,
layout(1)-1)
1099 write (*,120) (domain%y(1)%list(
i)%compute%
size,
i= 0,
layout(2)-1)
1100 110
format (' X-AXIS = ',24i4,/,(11x,24i4))
1101 120
format (' Y-AXIS = ',24i4,/,(11x,24i4))
1104 deallocate( pes, pesall)
1108 end subroutine mpp_define_domains2D
1111 !
##################################################################### 1112 subroutine check_message_size(domain, update,
send,
recv, position)
1113 type(domain2d), intent(in) :: domain
1114 type(overlapSpec), intent(in) :: update
1115 logical, intent(in) ::
send(:)
1116 logical, intent(in) ::
recv(:)
1117 character, intent(in) :: position
1123 nlist =
size(domain%list(:))
1128 do
m = 1, update%nrecv
1130 do
n = 1, update%
recv(
m)%count
1131 dir = update%
recv(
m)%dir(
n)
1140 call mpp_recv( msg1(l), glen=1,
from_pe=
from_pe, block=.FALSE., tag=COMM_TAG_1)
1144 do
m = 1, update%nsend
1146 do
n = 1, update%
send(
m)%count
1147 dir = update%
send(
m)%dir(
n)
1154 l = update%
send(
m)%
pe-mpp_root_pe()
1156 call mpp_send( msg3(l), plen=1,
to_pe=update%
send(
m)%
pe, tag=COMM_TAG_1)
1158 call mpp_sync_self(
check=EVENT_RECV)
1161 if(msg1(
m) .NE. msg2(
m)) then
1162 print*, "My
pe = ", mpp_pe(), ",domain
name =", trim(domain%
name), ",at position=",position,",from
pe=", &
1167 call mpp_sync_self()
1170 end subroutine check_message_size
1172 !
##################################################################### 1173 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1175 ! MPP_define_mosaic: define mosaic domain !
1176 ! NOTE: xflags and yflags
is not in mpp_define_mosaic, because such relation !
1177 ! are already defined in the mosaic relation. !
1179 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1180 !???
do we need optional argument xextent and yextent
1181 !??? how to specify
pelist, we may use
two dimensional variable
pelist to represent.
1182 !z1l: We assume the tilelist are in always limited to 1, 2, ... num_tile. If we want
1183 ! to
remove this limitation, we need to
add one more argument tilelist.
1184 subroutine mpp_define_mosaic( global_indices,
layout, domain, num_tile, num_contact, tile1, tile2, &
1185 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
1186 pe_end,
pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, &
1187 maskmap,
name, memory_size, symmetry, xflags, yflags, tile_id )
1189 ! The
size of second indice
is number of tiles in mosaic.
1191 type(domain2D), intent(inout) :: domain
1192 integer, intent(in) :: num_tile ! number of tiles in the mosaic
1193 integer, intent(in) :: num_contact ! number of contact region between tiles.
1194 integer, intent(in) :: tile1(:), tile2(:) !
tile number
1195 integer, intent(in) :: istart1(:), iend1(:) !
i-index in tile_1 of contact region
1196 integer, intent(in) :: jstart1(:), jend1(:) !
j-index in tile_1 of contact region
1197 integer, intent(in) :: istart2(:), iend2(:) !
i-index in tile_2 of contact region
1198 integer, intent(in) :: jstart2(:), jend2(:) !
j-index in tile_2 of contact region
1201 integer, intent(in), optional ::
pelist(:) ! list of processors used in mosaic
1202 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1203 integer, intent(in), optional :: xextent(:,:), yextent(:,:)
1204 logical, intent(in), optional :: maskmap(:,:,:)
1205 character(
len=*), intent(in), optional ::
name 1206 integer, intent(in), optional :: memory_size(2)
1207 logical, intent(in), optional :: symmetry
1208 integer, intent(in), optional :: xflags, yflags
1209 integer, intent(in), optional :: tile_id(:) ! tile_id of each
tile in the mosaic
1212 integer :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz,
t1,
t2,
tile 1215 integer,
allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
1217 logical :: is_symmetry
1218 integer,
allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
1221 type(overlapSpec), pointer :: update=>
NULL()
1222 character(
len=1) :: position
1230 !--- the
size of first indice of global_indices must be 4.
1232 'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
1233 !--- the
size of second indice of global_indices must be num_tile
1235 'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
1238 'mpp_domains_define.inc: The size of first dimension of layout is not 2')
1240 'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
1242 !--- setup
pelist for the mosaic ---------------------
1244 allocate(pes(0:nlist-1))
1247 'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
1250 call mpp_get_current_pelist(pes)
1252 !---
pelist should be monotonic increasing by 1.
1255 'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
1258 is_symmetry = .FALSE.
1259 if(present(symmetry)) is_symmetry = symmetry
1261 if(
size(pe_start(:)) .NE. num_tile .OR.
size(pe_end(:)) .NE. num_tile ) call
mpp_error(FATAL, &
1262 'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
1263 !--- make sure pe_start and pe_end
is in the
pelist.
1264 if( ANY( pe_start < pes(0) ) ) call
mpp_error(FATAL,
'mpp_domains_define.inc: not all the pe_start are in the pelist')
1265 if( ANY( pe_end > pes(nlist-1)) ) call
mpp_error(FATAL,
'mpp_domains_define.inc: not all the pe_end are in the pelist')
1267 !--- calculate number of tiles on each
pe.
1268 allocate( ntile_per_pe(0:nlist-1) )
1271 do
m = pe_start(
n) - mpp_root_pe(), pe_end(
n) - mpp_root_pe()
1272 ntile_per_pe(
m) = ntile_per_pe(
m) + 1
1275 if(ANY(ntile_per_pe == 0)) call
mpp_error(FATAL, &
1276 'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
1278 !---
check the
size comformable of xextent and yextent
1279 if( PRESENT(xextent) ) then
1281 'mpp_domains_define.inc: size mismatch between xextent and layout')
1283 'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
1285 if( PRESENT(yextent) ) then
1287 'mpp_domains_define.inc: size mismatch between yextent and layout')
1289 'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
1292 !---
check the
size comformable of maskmap
1293 !--- since the
layout is different between tiles, so the actual
size of maskmap for each
tile is 1294 !---
not diffrent. When define maskmap for multiple tiles, user can choose the maximum value
1295 !--- of
layout of all tiles to the first and second
dimension of maskmap.
1296 if(present(maskmap)) then
1298 call
mpp_error(FATAL,
'mpp_domains_define.inc: size mismatch between maskmap and layout')
1300 'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
1303 allocate(domain%tileList(num_tile))
1305 domain%tileList(
n)%xbegin = global_indices(1,
n)
1306 domain%tileList(
n)%xend = global_indices(2,
n)
1307 domain%tileList(
n)%ybegin = global_indices(3,
n)
1308 domain%tileList(
n)%yend = global_indices(4,
n)
1311 nt = ntile_per_pe(mpp_pe()-mpp_root_pe())
1312 allocate(domain%tile_id(
nt), domain%x(
nt), domain%y(
nt) )
1313 allocate(domain%list(0:nlist-1))
1316 nt = ntile_per_pe(
n)
1317 allocate(domain%list(
n)%x(
nt), domain%list(
n)%y(
nt), domain%list(
n)%tile_id(
nt) )
1322 if( PRESENT(tile_id) ) then
1323 if(
size(tile_id(:)) .NE. num_tile) then
1324 call
mpp_error(FATAL,
"mpp_domains_define.inc: size(tile_id) .NE. num_tile")
1327 allocate(tile_id_local(num_tile))
1329 !These directives are
a work-around for
a bug in the CCE compiler, which
1330 !causes
a segmentation fault when the compiler attempts to vectorize
a 1331 !loop containing an optional argument (when -
g is included).
1335 if(PRESENT(tile_id)) then
1336 tile_id_local(
n) = tile_id(
n)
1338 tile_id_local(
n) =
n 1344 if(
pe .GE. pe_start(
n) .AND.
pe .LE. pe_end(
n)) then
1346 domain%tile_id(
pos) = tile_id_local(
n)
1350 domain%initialized = .
true.
1351 domain%rotated_ninety = .FALSE.
1353 domain%max_ntile_pe = maxval(ntile_per_pe)
1354 domain%ncontacts = num_contact
1356 deallocate(ntile_per_pe)
1357 !---call mpp_define_domain to define domain decomposition for each
tile.
1358 allocate(tile_count(pes(0):pes(0)+nlist-1))
1359 tile_count = 0 !
tile number on current
pe 1363 allocate(pelist_tile(pe_start(
n):pe_end(
n)) )
1364 tile_count(pe_start(
n)) = tile_count(pe_start(
n)) + 1
1365 do
m = pe_start(
n), pe_end(
n)
1371 allocate(xext(ndivx), yext(ndivy))
1373 if(present(xextent)) xext = xextent(1:ndivx,
n)
1374 if(present(yextent)) yext = yextent(1:ndivy,
n)
1375 ! when num_tile
is one, we assume only folded_north and cyclic_x, cyclic_y boundary condition
is the possible
1376 ! z1l: when we decide to support multiple-
tile tripolar grid, we
will redesign the following part.
1377 if(num_tile == 1) then
1380 if(PRESENT(xflags)) flags_x = xflags
1381 if(PRESENT(yflags)) flags_y = yflags
1382 do m = 1, num_contact
1383 if(istart1(
m) == iend1(
m) ) then ! x-direction contact, possible
cyclic, folded-
west or folded-
east 1384 if(istart2(
m) .NE. iend2(
m) ) call
mpp_error(FATAL, &
1385 "mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
1386 if(istart1(
m) == istart2(
m) ) then ! folded
west or folded
east 1387 if(istart1(
m) == global_indices(1,
n) ) then
1388 if(.NOT. BTEST(flags_x,WEST) ) flags_x = flags_x + FOLD_WEST_EDGE
1389 else
if(istart1(
m) == global_indices(2,
n) ) then
1390 if(.NOT. BTEST(flags_x,EAST) ) flags_x = flags_x + FOLD_EAST_EDGE
1392 call
mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "
1393 "istart1 should
equal global_indices(1) or global_indices(2)")
1396 if(.NOT. BTEST(flags_x,CYCLIC)) flags_x = flags_x + CYCLIC_GLOBAL_DOMAIN
1398 else
if( jstart1(
m) == jend1(
m) ) then ! y-direction contact,
cyclic, folded-
south or folded-
north 1400 "mpp_domains_define: for
one tile mosaic, when jstart1=jend1, jstart2 must
equal jend2")
1401 if(jstart1(
m) == jstart2(
m) ) then ! folded
south or folded
north 1402 if(jstart1(
m) == global_indices(3,
n) ) then
1403 if(.NOT. BTEST(flags_y,SOUTH) ) flags_y = flags_y + FOLD_SOUTH_EDGE
1404 else
if(jstart1(
m) == global_indices(4,
n) ) then
1405 if(.NOT. BTEST(flags_y,NORTH) ) flags_y = flags_y + FOLD_NORTH_EDGE
1407 call
mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "
1408 "istart1 should
equal global_indices(1) or global_indices(2)")
1411 if(.NOT. BTEST(flags_y,CYCLIC)) flags_y = flags_y + CYCLIC_GLOBAL_DOMAIN
1415 "mpp_domains_define: for
one tile mosaic, invalid boundary contact")
1418 call mpp_define_domains(global_indices(:,
n),
layout(:,
n), domain,
pelist=pelist_tile, xflags = flags_x, &
1419 yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1420 xextent=xext, yextent=yext, maskmap=mask,
name=
name, symmetry=is_symmetry, &
1421 memory_size = memory_size, is_mosaic = .
true., tile_id=tile_id_local(
n))
1423 call mpp_define_domains(global_indices(:,
n),
layout(:,
n), domain,
pelist=pelist_tile, &
1424 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
1425 maskmap=mask,
name=
name, symmetry=is_symmetry, memory_size = memory_size, &
1426 is_mosaic = .
true., tile_count = tile_count(pe_start(
n)), tile_id=tile_id_local(
n), &
1427 complete =
n==num_tile)
1429 deallocate(mask, xext, yext, pelist_tile)
1432 deallocate(pes, tile_count)
1434 if(num_contact == 0 .OR. num_tile == 1) return
1436 !--- loop through each contact region and find the contact for each
tile ( including alignment )
1437 !--- we assume the tiles list
is continuous and starting from 1.
1438 allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
1439 allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
1440 allocate(isgList(num_tile), iegList(num_tile), jsgList(num_tile), jegList(num_tile) )
1441 allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
1444 isgList(
n) = domain%tileList(
n)%xbegin; iegList(
n) = domain%tileList(
n)%xend
1445 jsgList(
n) = domain%tileList(
n)%ybegin; jegList(
n) = domain%tileList(
n)%yend
1448 !--- transfer the contact index to domain index.
1450 do
n = 1, num_contact
1453 is1(
n) = istart1(
n) + isgList(
t1) - 1; ie1(
n) = iend1(
n) + isgList(
t1) - 1
1454 js1(
n) = jstart1(
n) + jsgList(
t1) - 1; je1(
n) = jend1(
n) + jsgList(
t1) - 1
1455 is2(
n) = istart2(
n) + isgList(
t2) - 1; ie2(
n) = iend2(
n) + isgList(
t2) - 1
1456 js2(
n) = jstart2(
n) + jsgList(
t2) - 1; je2(
n) = jend2(
n) + jsgList(
t2) - 1
1457 call check_alignment( is1(
n), ie1(
n), js1(
n), je1(
n), isgList(
t1), iegList(
t1), jsgList(
t1), jegList(
t1), align1(
n))
1458 call check_alignment( is2(
n), ie2(
n), js2(
n), je2(
n), isgList(
t2), iegList(
t2), jsgList(
t2), jegList(
t2), align2(
n))
1459 if( (align1(
n) == WEST .or. align1(
n) == EAST ) .NEQV. (align2(
n) == WEST .or. align2(
n) == EAST ) )&
1460 domain%rotated_ninety=.
true.
1463 !--- calculate the
refinement ratio between tiles
1464 do
n = 1, num_contact
1465 n1 =
max(abs(iend1(
n) - istart1(
n)), abs(jend1(
n) - jstart1(
n)) ) + 1
1466 n2 =
max(abs(iend2(
n) - istart2(
n)), abs(jend2(
n) - jstart2(
n)) ) + 1
1467 refine1(
n) = real(
n2)/n1
1468 refine2(
n) = real(n1)/
n2 1471 whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
1472 if(present(whalo)) whalosz = whalo
1473 if(present(ehalo)) ehalosz = ehalo
1474 if(present(shalo)) shalosz = shalo
1475 if(present(nhalo)) nhalosz = nhalo
1476 xhalosz =
max(whalosz, ehalosz)
1477 yhalosz =
max(shalosz, nhalosz)
1479 !--- computing the overlap for the contact region with halo
size xhalosz and yhalosz
1480 call define_contact_point( domain, CENTER, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
1481 is1, ie1, js1, je1, is2, ie2, js2, je2, isgList, iegList, jsgList, jegList )
1483 call set_contact_point( domain, CORNER )
1484 call set_contact_point( domain, EAST )
1485 call set_contact_point( domain, NORTH )
1487 call set_domain_comm_inf(domain%update_T)
1488 call set_domain_comm_inf(domain%update_E)
1489 call set_domain_comm_inf(domain%update_C)
1490 call set_domain_comm_inf(domain%update_N)
1493 !--- goffset setting
is needed for exact
global sum
1494 do
m = 1,
size(domain%tile_id(:))
1495 tile = domain%tile_id(
m)
1496 do
n = 1, num_contact
1498 if(align1(
n) == EAST ) domain%x(
m)%goffset = 0
1499 if(align1(
n) == NORTH) domain%y(
m)%goffset = 0
1502 if(align2(
n) == EAST ) domain%x(
m)%goffset = 0
1503 if(align2(
n) == NORTH) domain%y(
m)%goffset = 0
1507 call check_overlap_pe_order(domain, domain%update_T, trim(domain%
name)
1508 call check_overlap_pe_order(domain, domain%update_C, trim(domain%
name)
1509 call check_overlap_pe_order(domain, domain%update_E, trim(domain%
name)
1510 call check_overlap_pe_order(domain, domain%update_N, trim(domain%
name)
1512 !---
set the overlapping for boundary
check if domain
is symmetry
1514 call set_check_overlap( domain, CORNER )
1515 call set_check_overlap( domain, EAST )
1516 call set_check_overlap( domain, NORTH )
1518 if(domain%symmetry) then
1519 allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1520 call set_bound_overlap( domain, CORNER )
1521 call set_bound_overlap( domain, EAST )
1522 call set_bound_overlap( domain, NORTH )
1523 call check_overlap_pe_order(domain, domain%bound_C, trim(domain%
name)
1524 call check_overlap_pe_order(domain, domain%bound_E, trim(domain%
name)
1525 call check_overlap_pe_order(domain, domain%bound_N, trim(domain%
name)
1529 !--- currently only
check T and C-cell. For
ntiles>1 mosaic,
1530 !--- the
check will be done in mpp_define_mosaic
1534 call check_message_size(domain, domain%update_T,
send,
recv, '
T')
1535 call check_message_size(domain, domain%update_C,
send,
recv, 'C')
1536 call check_message_size(domain, domain%update_E,
send,
recv, 'E')
1537 call check_message_size(domain, domain%update_N,
send,
recv, 'N')
1542 deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2 )
1543 deallocate(isgList, iegList, jsgList, jegList, refine1, refine2 )
1546 end subroutine mpp_define_mosaic
1548 !
##################################################################### 1549 logical
function mpp_mosaic_defined()
1552 end function mpp_mosaic_defined
1553 !#####################################################################
1555 subroutine compute_overlaps( domain, position, update,
check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
1556 whalo, ehalo, shalo, nhalo )
1557 !computes remote domain overlaps
1558 !assumes only
one in each direction
1559 !
will calculate the overlapping
for T,E,C,N-cell seperately.
1560 type(domain2D), intent(inout) :: domain
1561 type(overlapSpec), intent(inout), pointer :: update
1562 type(overlapSpec), intent(inout), pointer ::
check 1563 integer, intent(in) :: position, ishift, jshift
1564 integer, intent(in) :: x_cyclic_offset, y_cyclic_offset
1565 integer, intent(in) :: whalo, ehalo, shalo, nhalo
1568 integer ::
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isd,
ied,
jsd,
jed 1570 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
1574 integer :: isd3, ied3, jsd3, jed3
1575 integer :: isd2, ied2, jsd2, jed2
1576 logical :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
1577 type(overlap_type) :: overlap
1578 type(overlap_type), pointer :: overlapList(:)=>
NULL()
1579 type(overlap_type), pointer :: checkList(:)=>
NULL()
1581 integer :: nsend_check, nrecv_check
1583 logical :: set_check
1585 !--- since we restrict that
if multiple tiles on
one pe, all the tiles are limited to this
pe.
1586 !--- In this
case,
if ntiles on this
pe is greater than 1,
no overlapping between processor within each
tile 1587 !--- In this
case the overlapping exist only for tMe=1 and tNbr=1
1588 if(
size(domain%x(:)) > 1) return
1590 !---
if there
is no halo,
no need to compute overlaps.
1591 if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0) return
1594 nlist =
size(domain%list(:))
1597 allocate(overlapList(MAXLIST) )
1598 if(set_check) allocate(checkList(MAXLIST) )
1600 !--- overlap
is used to store the overlapping temporarily.
1601 call allocate_update_overlap( overlap, MAXOVERLAP)
1603 call mpp_get_compute_domain( domain,
isc,
iec,
jsc,
jec, position=position )
1604 call mpp_get_global_domain ( domain,
isg,
ieg,
jsg,
jeg, xsize=ni, ysize=nj, position=position ) !
cyclic offsets
1605 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
1607 update%xbegin = ism; update%xend = iem
1608 update%ybegin = jsm; update%yend = jem
1613 update%whalo = whalo; update%ehalo = ehalo
1614 update%shalo = shalo; update%nhalo = nhalo
1620 folded_north = BTEST(domain%fold,NORTH)
1621 if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,EAST) .OR. BTEST(domain%fold,WEST) ) then
1622 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition " 1623 "is not supported, please use other version of compute_overlaps for " 1630 m = mod( domain%
pos+list, nlist )
1631 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
1632 !
to_pe's eastern halo 1634 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift 1635 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 1636 !--- to make sure the consistence between pes 1637 if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) & 1638 .AND. ( jsc == je .or. jec == js ) ) then 1639 !--- do nothing, this point will come from other pe 1641 !--- when the north face is folded, the east halo point at right side domain will be folded. 1642 !--- the position should be on CORNER or NORTH 1643 if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then 1644 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1645 isg, ieg, dir, ishift, position, ioff, middle) 1647 if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then 1648 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1649 isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry) 1651 if( ie.GT.ieg ) then 1652 if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset 1653 is = is-ioff; ie = ie-ioff 1654 call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj) 1657 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1658 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry) 1665 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
1666 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
1667 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1668 !---
divide into
two parts,
one part
is x_cyclic_offset/y_cyclic_offset
is non-zeor,
1669 !--- the other part
is both are
zero.
1670 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1671 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1673 if( domain%y(tMe)%
cyclic ) then
1676 else if(
js .Lt.
jsg) then ! split into
two parts
1677 if( domain%y(tMe)%
cyclic ) then
1678 js2 =
js + joff; je2 =
jsg-1+joff
1682 call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
1684 if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie, js2, je2,
isc,
iec,
jsc,
jec, &
1690 need_adjust_1 = .false.
1691 if(
jsg .GT.
js) then
1694 need_adjust_2 = .false.
1695 if(x_cyclic_offset .NE. 0) then
1696 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
1697 else if(y_cyclic_offset .NE. 0) then
1698 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
1702 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
1703 need_adjust_3 = .false.
1707 if( need_adjust_3 .AND.
jsg.GT.js )then
1710 if(need_adjust_1 .AND.
ie.LE.ieg) then
1711 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
1715 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isg,
ieg,
jsg,
jeg, dir)
1718 !
to_pe's southern halo 1720 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 1721 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 1723 if( jsg.GT.je )then ! jsg .GT. js 1724 if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset 1725 js = js+joff; je = je+joff 1726 call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni) 1728 else if (jsg .GT. js) then ! split into two parts 1729 if( domain%y(tMe)%cyclic) then 1730 js2 = js + joff; je2 = jsg-1+joff 1735 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1736 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry) 1737 if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, & 1738 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry) 1742 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
1743 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
1744 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1745 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1746 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1748 if( domain%y(tMe)%
cyclic ) then
1751 else if(
js .Lt.
jsg) then ! split into
two parts
1752 if( domain%y(tMe)%
cyclic ) then
1753 js2 =
js + joff; je2 =
jsg-1+joff
1757 call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
1759 if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie, js2, je2,
isc,
iec,
jsc,
jec, &
1765 need_adjust_1 = .false.
1766 if(
jsg .GT.
js) then
1769 need_adjust_2 = .false.
1770 if(x_cyclic_offset .NE. 0) then
1771 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
1772 else if(y_cyclic_offset .NE. 0) then
1773 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
1777 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
1778 need_adjust_3 = .false.
1782 if( need_adjust_3 .AND.
jsg.GT.js )then
1785 if(need_adjust_1 .AND.
isg.LE.is )then
1786 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
1790 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isg,
ieg,
jsg,
jeg, dir)
1793 !
to_pe's western halo 1795 is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1 1796 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 1798 !--- when the north face is folded, some point at j=nj will be folded. 1799 !--- the position should be on CORNER or NORTH 1800 if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then 1801 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1802 isg, ieg, dir, ishift, position, ioff, middle) 1804 if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then 1805 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1806 isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry) 1809 if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset 1810 is = is+ioff; ie = ie+ioff 1811 call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj) 1814 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1815 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry) 1821 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
1822 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
1823 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1824 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
1826 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1828 if( domain%y(tMe)%
cyclic ) then
1830 else if(folded_north )then
1834 else if(
je .GT.
jeg) then ! split into
two parts
1835 if( domain%y(tMe)%
cyclic ) then
1838 else if(folded_north) then
1843 if(
is .GT.
ieg) then
1845 else if(
ie .GT.
ieg ) then
1852 if(
je ==
jeg .AND.
jec ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1853 call fill_overlap_send_fold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
1854 isg,
ieg, dir, ishift, position, ioff, middle)
1856 call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
1859 if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain,
m, is3, ie3, js3, je3, &
1861 if(ie2 .GE. is2) then
1862 if(je2 ==
jeg .AND.
jec ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1863 call fill_overlap_send_fold(overlap, domain,
m, is2, ie2, js2, je2,
isc,
iec,
jsc,
jec, &
1864 isg,
ieg, dir, ishift, position, ioff, middle)
1866 call fill_overlap_send_nofold(overlap, domain,
m, is2, ie2, js2, je2,
isc,
iec,
jsc,
jec, &
1871 need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1875 need_adjust_1 = .false.
1876 if(
je .GT.
jeg) then
1879 need_adjust_2 = .false.
1880 if(x_cyclic_offset .NE. 0) then
1881 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
1882 else if(y_cyclic_offset .NE. 0) then
1883 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
1887 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
1888 need_adjust_3 = .false.
1893 if( need_adjust_3 .AND.
je.GT.jeg )then
1896 if( need_adjust_1 .AND.
isg.LE.is)then
1897 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
1899 else if( folded_north )then
1904 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
1909 !
to_pe's northern halo 1912 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 1913 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 1915 !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie, 1916 !--- no need to send, because the data on that point will come from other pe. 1917 !--- come from two pe ( there will be only one point on one pe. ). 1918 if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) & 1919 .AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) ) then 1920 !--- do nothing, this point will come from other pe 1923 if( js .GT. jeg) then ! je .GT. jeg 1924 if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset 1925 js = js-joff; je = je-joff 1926 call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni) 1927 else if( folded_north )then 1929 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je) 1931 else if( je.GT.jeg )then ! split into two parts 1932 if( domain%y(tMe)%cyclic)then !try cyclic offset 1933 is2 = is; ie2 = ie; js2 = js; je2 = jeg 1934 js = jeg+1-joff; je = je - joff 1935 else if( folded_north )then 1937 is2 = is; ie2 = ie; js2 = js; je2 = jeg 1939 call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je) 1942 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then 1943 if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then 1944 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1945 isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry) 1947 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1948 isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, domain%symmetry) 1951 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, & 1952 isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry) 1955 if(ie2 .GE. is2) then 1956 if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then 1957 call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, & 1958 isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry) 1960 call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, & 1961 isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry) 1966 !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER 1967 if(is .LT. isg .AND. domain%x(tMe)%cyclic) then 1969 ! call insert_update_overlap( overlap, domain%list(m)%pe, & 1970 ! is, is, js, je, isc, iec, jsc, jec, dir, folded) 1971 !??? if(je2 .GE. js2)call insert_update_overlap( overlap, domain%list(m)%pe, & 1972 ! is, is, js2, je2, isc, iec, jsc, jec, dir, folded) 1975 !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north 1976 !--- for folded-north-edge, only need to consider to_pe's
north(7) direction
1977 !--- only position at NORTH and CORNER need to be considered
1978 if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
1979 .AND. domain%x(tMe)%
pos .LT. (
size(domain%x(tMe)%list(:))+1)/2 ) then
1980 if( domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift .GE.
jeg .AND.
isc .LE. middle)then
1982 is = domain%list(
m)%x(tNbr)%compute%
begin;
ie = domain%list(
m)%x(tNbr)%compute%
end+ishift
1984 select
case (position)
1990 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
1994 je = domain%list(
m)%y(tNbr)%compute%
end+jshift;
1999 nsend_check = nsend_check+1
2000 if(nsend_check >
size(checkList(:)) ) then
2001 call expand_check_overlap_list(checkList, nlist)
2003 call allocate_check_overlap(checkList(nsend_check), 1)
2004 call insert_check_overlap(checkList(nsend_check), domain%list(
m)%
pe, &
2005 tMe, 4, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
2013 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
2014 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
2015 is2 = 0; ie2=-1; js2=0; je2=-1
2016 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2017 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2022 else
if(folded_north )then
2026 else
if(
je .GT.
jeg) then ! split into
two parts
2030 else
if(folded_north) then
2044 if(
je ==
jeg .AND.
jec ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
2045 call fill_overlap_send_fold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2046 isg,
ieg, dir, ishift, position, ioff, middle)
2048 call fill_overlap_send_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2051 if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain,
m, is3, ie3, js3, je3, &
2053 if(ie2 .GE. is2) then
2054 if(je2 ==
jeg .AND.
jec ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
2055 call fill_overlap_send_fold(overlap, domain,
m, is2, ie2, js2, je2,
isc,
iec,
jsc,
jec, &
2056 isg,
ieg, dir, ishift, position, ioff, middle)
2058 call fill_overlap_send_nofold(overlap, domain,
m, is2, ie2, js2, je2,
isc,
iec,
jsc,
jec, &
2063 need_adjust_1 = .
true.; need_adjust_2 = .
true.; need_adjust_3 = .
true.
2067 need_adjust_1 = .
false.
2071 need_adjust_2 = .
false.
2072 if(x_cyclic_offset .NE. 0) then
2073 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
2074 else
if(y_cyclic_offset .NE. 0) then
2075 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
2079 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
2080 need_adjust_3 = .
false.
2085 if( need_adjust_3 .AND.
je.GT.
jeg )then
2088 if( need_adjust_1 .AND.
ie.LE.
ieg)then
2089 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
2091 else
if( folded_north )then
2096 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2102 if( overlap%count > 0) then
2104 if(nsend >
size(overlapList(:)) ) then
2105 call
mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for
send is expanded')
2106 call expand_update_overlap_list(overlapList, nlist)
2108 call add_update_overlap( overlapList(nsend), overlap)
2109 call init_overlap_type(overlap)
2115 unit = mpp_pe() + 1000
2117 write(
unit, *) "********
to_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
2118 do
n = 1, overlapList(
m)%count
2119 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
2120 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
2123 if(nsend >0) call flush(
unit)
2128 allocate(update%
send(nsend))
2129 update%nsend = nsend
2131 call add_update_overlap( update%
send(
m), overlapList(
m) )
2135 if(nsend_check>0) then
2136 check%nsend = nsend_check
2138 do
m = 1, nsend_check
2139 call add_check_overlap(
check%
send(
m), checkList(
m) )
2143 do
m = 1,
size(overlapList(:))
2144 call deallocate_overlap_type(overlapList(
m))
2148 do
m = 1,
size(checkList(:))
2149 call deallocate_overlap_type(checkList(
m))
2153 isgd =
isg - domain%whalo
2154 iegd =
ieg + domain%ehalo
2155 jsgd =
jsg - domain%shalo
2156 jegd =
jeg + domain%nhalo
2162 m = mod( domain%
pos+nlist-list, nlist )
2163 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
2164 isc = domain%list(
m)%x(1)%compute%
begin;
iec = domain%list(
m)%x(1)%compute%
end+ishift
2165 jsc = domain%list(
m)%y(1)%compute%
begin;
jec = domain%list(
m)%y(1)%compute%
end+jshift
2168 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%compute%
end+ehalo+ishift
2169 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
2171 if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
2173 ! --- do nothing, this point
will come from other
pe 2175 !--- when the
north face
is folded, the
east halo point at right side domain
will be folded.
2176 !--- the position should be on CORNER or NORTH
2177 if(
jed ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2178 call fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2179 isg,
ieg, dir, ishift, position, ioff, middle)
2181 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2182 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2188 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
2191 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2199 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%compute%
end+ehalo+ishift
2200 jsd = domain%y(tMe)%compute%
begin-shalo;
jed = domain%y(tMe)%compute%
begin-1
2202 !---
divide into
two parts,
one part
is x_cyclic_offset/y_cyclic_offset
is non-zeor,
2203 !--- the other part
is both are
zero.
2204 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2205 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2212 js2 =
js-joff; je2 =
je-joff
2215 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2217 if(je2 .GE. js2) call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie, js2, je2,
isd,
ied,
jsd,
jed, &
2220 need_adjust_1 = .
true.; need_adjust_2 = .
true.; need_adjust_3 = .
true.
2224 need_adjust_1 = .
false.
2228 need_adjust_2 = .
false.
2229 if(x_cyclic_offset .NE. 0) then
2230 call apply_cyclic_offset(
js,
je, x_cyclic_offset, jsgd,
jeg, nj)
2231 else
if(y_cyclic_offset .NE. 0) then
2232 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg, iegd, ni)
2236 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
2237 need_adjust_3 = .
false.
2241 if( need_adjust_3 .AND.
ied.GT.
ieg )then
2244 if( need_adjust_1 .AND.
jsd.GE.
jsg )then
2245 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
2249 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2255 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
2256 jsd = domain%y(tMe)%compute%
begin-shalo;
jed = domain%y(tMe)%compute%
begin-1
2262 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
2266 js2 =
js-joff; je2 =
je-joff
2269 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2271 if(je2 .GE. js2) call fill_overlap(overlap, domain,
m,
is,
ie, js2, je2,
isd,
ied,
jsd,
jed, &
2276 isd = domain%x(tMe)%compute%
begin-whalo;
ied = domain%x(tMe)%compute%
begin-1
2277 jsd = domain%y(tMe)%compute%
begin-shalo;
jed = domain%y(tMe)%compute%
begin-1
2279 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2280 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2287 is2 =
is-ioff; ie2 =
ie-ioff
2296 js2 =
js-joff; je2 =
je-joff
2300 need_adjust_1 = .
true.; need_adjust_2 = .
true.; need_adjust_3 = .
true.
2304 need_adjust_1 = .
false.
2308 need_adjust_2 = .
false.
2309 if(x_cyclic_offset .NE. 0) then
2310 call apply_cyclic_offset(
js,
je, -x_cyclic_offset, jsgd,
jeg, nj)
2311 else
if(y_cyclic_offset .NE. 0) then
2312 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset, isgd,
ieg, ni)
2316 call apply_cyclic_offset(
is,
ie, -y_cyclic_offset,
isg,
ieg, ni)
2317 need_adjust_3 = .
false.
2321 if( need_adjust_3 .AND.
isd.LT.
isg )then
2324 if(need_adjust_1 .AND.
jsd.GE.
jsg) then
2325 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
2330 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2333 if(ie2 .GE. is2)call fill_overlap(overlap, domain,
m, is2, ie2,
js,
je,
isd,
ied,
jsd,
jed, &
2335 if(je2 .GE. js2)call fill_overlap(overlap, domain,
m,
is,
ie, js2, je2,
isd,
ied,
jsd,
jed, &
2338 if(ie2 .GE. is2 .AND. je2 .GE. js2)call fill_overlap(overlap, domain,
m, is2, ie2, js2, je2,
isd,
ied,
jsd,
jed, &
2344 isd = domain%x(tMe)%compute%
begin-whalo;
ied = domain%x(tMe)%compute%
begin-1
2345 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
2349 !--- the position should be on CORNER or NORTH
2350 if(
jed ==
jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2351 call fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2352 isg,
ieg, dir, ishift, position, ioff, middle)
2354 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2355 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2356 isg,
ieg, dir, ioff, domain%x(tMe)%
cyclic, symmetry=domain%symmetry)
2361 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
2364 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2372 isd = domain%x(tMe)%compute%
begin-whalo;
ied = domain%x(tMe)%compute%
begin-1
2373 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%compute%
end+nhalo+jshift
2375 is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2376 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2377 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2382 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
2383 else
if( folded_north )then
2389 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2393 else
if( folded_north )then
2395 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2402 is3 =
is-ioff; ie3=
ie-ioff
2410 .AND. (position == CORNER .OR. position == NORTH)) then
2411 call fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2412 isg,
ieg, dir, ishift, position, ioff, middle)
2414 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2418 if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain,
m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
2421 if(ie2 .GE. is2) then
2422 if(
jeg .GE. js2 .AND.
jeg .LE. je2 .AND. jed2 ==
jeg .AND. folded_north &
2423 .AND. (position == CORNER .OR. position == NORTH)) then
2424 call fill_overlap_recv_fold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2425 isg,
ieg, dir, ishift, position, ioff, middle)
2427 call fill_overlap_recv_nofold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2432 need_adjust_1 = .
true.; need_adjust_2 = .
true.; need_adjust_3 = .
true.
2436 need_adjust_1 = .
false.
2440 need_adjust_2 = .
false.
2441 if(x_cyclic_offset .NE. 0) then
2442 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg, jegd, nj)
2443 else
if(y_cyclic_offset .NE. 0) then
2444 call apply_cyclic_offset(
is,
ie, y_cyclic_offset, isgd,
ieg, ni)
2448 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
2449 need_adjust_3 = .
false.
2451 else
if( folded_north )then
2456 if( need_adjust_3 .AND.
isd.LT.
isg )then
2459 if( need_adjust_1 .AND.
jed.LE.
jeg )then
2460 call apply_cyclic_offset(
js,
je, -x_cyclic_offset,
jsg,
jeg, nj)
2464 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2468 !--- when
north edge
is folded,
is will be less than
isg when position
is EAST and CORNER
2471 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
2478 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
2479 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%compute%
end+nhalo+jshift
2482 !--- when domain symmetry and position
is EAST or CORNER, the point at
i=
isd will 2484 if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
2485 .AND. (
isd ==
ie .or.
ied ==
is ) .AND. (.
not. folded_north) ) then
2486 !--- do nothing, this point
will come from other
pe 2492 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
2493 else
if( folded_north )then
2499 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2503 else
if( folded_north )then
2505 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2511 if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0) then
2513 .AND. (position == CORNER .OR. position == NORTH)) then
2514 call fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2515 isg,
ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2517 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2518 isg,
ieg, dir, ioff, domain%x(tMe)%
cyclic, folded, symmetry=domain%symmetry)
2521 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2524 if(ie2 .GE. is2) then
2525 if(
jeg .GE. js2 .AND.
jeg .LE. je2 .AND. jed2 ==
jeg .AND. folded_north &
2526 .AND. (position == CORNER .OR. position == NORTH)) then
2527 call fill_overlap_recv_fold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2528 isg,
ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2530 call fill_overlap_recv_nofold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2531 isg,
ieg, dir, ioff, domain%x(tMe)%
cyclic, folded, symmetry=domain%symmetry)
2536 !--- when
north edge
is folded,
ie will be less than
isg when position
is EAST and CORNER
2539 ! call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2543 !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-
north 2544 !--- for folded-
north-edge, only need to consider
to_pe's
north(7) direction
2545 !--- only position at NORTH and CORNER need to be considered
2547 if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
2548 .AND. domain%x(tMe)%
pos .GE.
size(domain%x(tMe)%list(:))/2) then
2553 select
case (position)
2559 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
2568 nrecv_check = nrecv_check+1
2569 if(nrecv_check >
size(checkList(:)) ) then
2570 call expand_check_overlap_list(checkList, nlist)
2572 call allocate_check_overlap(checkList(nrecv_check), 1)
2573 call insert_check_overlap(checkList(nrecv_check), domain%list(
m)%
pe, &
2574 tMe, 4, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
2584 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%compute%
end+ehalo+ishift
2585 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%compute%
end+nhalo+jshift
2587 is2 = 0; ie2=-1; js2=0; je2=-1
2588 is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2589 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2594 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
2595 else
if( folded_north )then
2601 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2605 else
if( folded_north )then
2607 is2 =
is; ie2 =
ie; js2 =
js; je2 =
je 2614 is3 =
is+ioff; ie3=
ie+ioff
2621 .AND. (position == CORNER .OR. position == NORTH)) then
2622 call fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2623 isg,
ieg, dir, ishift, position, ioff, middle)
2625 call fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2628 if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain,
m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
2630 if(ie2 .GE. is2) then
2631 if(
jeg .GE. js2 .AND.
jeg .LE. je2 .AND. jed2 ==
jeg .AND. folded_north &
2632 .AND. (position == CORNER .OR. position == NORTH)) then
2633 call fill_overlap_recv_fold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2634 isg,
ieg, dir, ishift, position, ioff, middle)
2636 call fill_overlap_recv_nofold(overlap, domain,
m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2641 need_adjust_1 = .
true.; need_adjust_2 = .
true.; need_adjust_3 = .
true.
2645 need_adjust_1 = .
false.
2649 need_adjust_2 = .
false.
2650 if(x_cyclic_offset .NE. 0) then
2651 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg, jegd, nj)
2652 else
if(y_cyclic_offset .NE. 0) then
2653 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg, iegd, ni)
2657 call apply_cyclic_offset(
is,
ie, y_cyclic_offset,
isg,
ieg, ni)
2658 need_adjust_3 = .
false.
2660 else
if( folded_north )then
2665 if( need_adjust_3 .AND.
ied.GT.
ieg )then
2668 if( need_adjust_1 .AND.
jed.LE.
jeg)then
2669 call apply_cyclic_offset(
js,
je, x_cyclic_offset,
jsg,
jeg, nj)
2673 call fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2679 if( overlap%count > 0) then
2681 if(nrecv >
size(overlapList(:)) )then
2682 call
mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for
recv is expanded')
2683 call expand_update_overlap_list(overlapList, nlist)
2685 call add_update_overlap( overlapList(nrecv), overlap)
2686 call init_overlap_type(overlap)
2692 unit = mpp_pe() + 1000
2694 write(
unit, *) "********
from_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
2695 do
n = 1, overlapList(
m)%count
2696 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
2697 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
2700 if(nrecv >0) call flush(
unit)
2705 allocate(update%
recv(nrecv))
2706 update%nrecv = nrecv
2708 call add_update_overlap( update%
recv(
m), overlapList(
m) )
2709 do
n = 1, update%
recv(
m)%count
2710 if(update%
recv(
m)%tileNbr(
n) == domain%tile_id(tMe)) then
2711 if(update%
recv(
m)%dir(
n) == 1) domain%x(tMe)%loffset = 0
2712 if(update%
recv(
m)%dir(
n) == 7) domain%y(tMe)%loffset = 0
2718 if(nrecv_check>0) then
2719 check%nrecv = nrecv_check
2721 do
m = 1, nrecv_check
2722 call add_check_overlap(
check%
recv(
m), checkList(
m) )
2726 call deallocate_overlap_type(overlap)
2727 do
m = 1,
size(overlapList(:))
2728 call deallocate_overlap_type(overlapList(
m))
2732 do
m = 1,
size(checkList(:))
2733 call deallocate_overlap_type(checkList(
m))
2737 deallocate(overlapList)
2738 if(set_check) deallocate(checkList)
2739 domain%initialized = .
true.
2741 end subroutine compute_overlaps
2744 subroutine fill_overlap_send_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2745 isg,
ieg, dir, ioff, is_cyclic, folded, symmetry)
2746 type(overlap_type), intent(inout) :: overlap
2747 type(domain2d), intent(inout) :: domain
2751 logical, intent(in ) :: is_cyclic
2752 logical, optional, intent(in ) :: folded, symmetry
2754 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2755 is,
ie,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse=folded, symmetry=symmetry)
2758 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2759 is-ioff,
ie-ioff,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse=folded, symmetry=symmetry)
2761 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2762 is+ioff,
ie+ioff,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse=folded, symmetry=symmetry)
2766 end subroutine fill_overlap_send_nofold
2767 !
################################################################################## 2768 subroutine fill_overlap_send_fold(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2769 isg,
ieg, dir, ishift, position, ioff, middle, symmetry)
2770 type(overlap_type), intent(inout) :: overlap
2771 type(domain2d), intent(inout) :: domain
2774 integer, intent(in ) ::
isg,
ieg, dir, ishift, position, ioff, middle
2775 logical, optional, intent(in ) :: symmetry
2778 !--- consider at
j =
jeg for
west edge.
2780 if(position == CORNER .AND. .NOT. domain%symmetry .AND.
is .LE.
isg-1 .AND.
ie .GE.
isg-1) then
2781 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
2785 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2788 is2 =
is-ioff; ie2 =
ie-ioff
2789 else if(
ie >
ieg ) then ! split into
two parts
2791 is2 =
ieg+1-ioff; ie2 =
ie-ioff
2792 else if(
is .GE. middle ) then
2794 else if(
ie .GE. middle ) then ! split into
two parts
2795 is1 = middle; ie1 =
ie 2796 is2 =
is; ie2 = middle-1
2797 else if(
ie <
isg ) then !
west boundary
2799 else if(
is <
isg ) then ! split into
two parts
2806 if( ie1 .GE. is1) then
2807 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2810 select
case (position)
2816 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2817 is1, ie1,
je,
je,
isc,
iec,
jsc,
jec, dir, .
true., symmetry=symmetry)
2820 if(ie2 .GE. is2) then
2821 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2825 end subroutine fill_overlap_send_fold
2828 !#############################################################################
2829 subroutine fill_overlap_recv_nofold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2830 isg,
ieg, dir, ioff, is_cyclic, folded, symmetry)
2831 type(overlap_type), intent(inout) :: overlap
2832 type(domain2d), intent(inout) :: domain
2836 logical, intent(in ) :: is_cyclic
2837 logical, optional, intent(in ) :: folded, symmetry
2839 integer :: isd1, ied1, isd2, ied2
2841 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2845 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2846 is,
ie,
js,
je,
isd,
ied,
jsd,
jed, dir,
reverse=folded, symmetry=symmetry)
2849 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2850 is+ioff,
ie+ioff,
js,
je,
isd,
ied,
jsd,
jed, dir,
reverse=folded, symmetry=symmetry)
2851 else if(
isd .LT.
isg ) then
2852 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2853 is-ioff,
ie-ioff,
js,
je,
isd,
ied,
jsd,
jed, dir,
reverse=folded, symmetry=symmetry)
2854 else if (
is .LT.
isg ) then
2855 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2856 is+ioff,
ie+ioff,
js,
je,
isd,
ied,
jsd,
jed, dir,
reverse=folded, symmetry=symmetry)
2857 else if (
ie .GT.
ieg ) then
2858 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2859 is-ioff,
ie-ioff,
js,
je,
isd,
ied,
jsd,
jed, dir,
reverse=folded, symmetry=symmetry)
2863 end subroutine fill_overlap_recv_nofold
2864 !#################################################################################
2865 subroutine fill_overlap_recv_fold(overlap, domain,
m,
is,
ie,
js,
je,
isd,
ied,
jsd,
jed, &
2866 isg,
ieg, dir, ishift, position, ioff, middle, symmetry)
2867 type(overlap_type), intent(inout) :: overlap
2868 type(domain2d), intent(inout) :: domain
2871 integer, intent(in ) ::
isg,
ieg, dir, ishift, position, ioff, middle
2872 logical, optional, intent(in ) :: symmetry
2873 integer :: is1, ie1, is2, ie2, is3, ie3
2874 integer :: isd1, ied1, isd2, ied2
2876 !--- consider at
j =
jeg for
west edge.
2878 if( position == CORNER .AND. .NOT. domain%symmetry .AND.
isd .LE.
isg-1 .AND.
ied .GE.
isg-1 ) then
2879 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2883 is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2886 select
case (position)
2894 is2 =
is + ioff; ie2 =
ie + ioff;
2895 else if(
ied .GT.
ieg) then ! split into
two parts
2898 is2 =
is + ioff; ie2 =
ie + ioff
2899 isd2 =
ieg + 1; ied2 =
ied 2900 else if(
isd .GE. middle) then
2902 else if(
ied .GE. middle) then ! split into
two parts
2904 isd1 = middle; ied1 =
ied 2906 isd2 =
isd; ied2 = middle-1
2907 else if(
ied .LT.
isg) then
2908 is1 =
is - ioff; ie1 =
ie - ioff;
2909 is3 = is3 - ioff; ie3 = ie3 - ioff;
2910 else if(
isd .LT.
isg) then ! split into
two parts
2911 is1 =
is - ioff; ie1 =
ie - ioff;
2912 is3 = is3 - ioff; ie3 = ie3 - ioff;
2921 if( ie1 .GE. is1) then
2922 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2923 is1, ie1,
js,
je, isd1, ied1,
jsd,
jed-1, dir, symmetry=symmetry)
2925 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2926 is3, ie3,
js,
je, isd1, ied1,
jed,
jed, dir, .
true., symmetry=symmetry)
2929 if(ie2 .GE. is2) then
2930 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2934 end subroutine fill_overlap_recv_fold
2936 !#####################################################################################
2937 subroutine fill_overlap(overlap, domain,
m,
is,
ie,
js,
je,
isc,
iec,
jsc,
jec, &
2939 type(overlap_type), intent(inout) :: overlap
2940 type(domain2d), intent(inout) :: domain
2945 logical, optional, intent(in ) ::
reverse, symmetry
2947 if(
js >
je) then ! seperate into
two regions due to x_cyclic_offset
is nonzero, the
two region are
2949 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2950 is,
ie,
jsg,
je,
isc,
iec,
jsc,
jec, dir,
reverse, symmetry)
2951 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2952 is,
ie,
js,
jeg,
isc,
iec,
jsc,
jec, dir,
reverse, symmetry)
2953 else
if(
is >
ie) then ! seperate into
two regions due to y_cyclic_offset
is nonzero, the
two region are
2955 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2956 is,
ieg,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse, symmetry)
2957 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2958 isg,
ie,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse, symmetry)
2960 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
2961 is,
ie,
js,
je,
isc,
iec,
jsc,
jec, dir,
reverse, symmetry)
2965 end subroutine fill_overlap
2967 !####################################################################################
2968 subroutine compute_overlaps_fold_south( domain, position, ishift, jshift)
2969 !computes remote domain overlaps
2970 !assumes only
one in each direction
2971 !
will calculate the overlapping for
T,E,C,N-cell seperately.
2972 type(domain2D), intent(inout) :: domain
2973 integer, intent(in) :: position, ishift, jshift
2976 integer ::
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isd,
ied,
jsd,
jed 2978 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
2979 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
2981 type(overlap_type) :: overlap
2982 type(overlapSpec), pointer :: update=>
NULL()
2983 type(overlap_type), pointer :: overlapList(:)=>
NULL()
2984 type(overlap_type), pointer :: checkList(:)=>
NULL()
2987 integer :: nsend_check, nrecv_check
2990 !--- since we restrict that
if multiple tiles on
one pe, all the tiles are limited to this
pe.
2991 !--- In this
case,
if ntiles on this
pe is greater than 1,
no overlapping between processor within each
tile 2992 !--- In this
case the overlapping exist only for tMe=1 and tNbr=1
2993 if(
size(domain%x(:)) > 1) return
2995 !---
if there
is no halo,
no need to compute overlaps.
2996 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
2999 nlist =
size(domain%list(:))
3001 select
case(position)
3003 update => domain%update_T
3006 update => domain%update_C
3007 check => domain%check_C
3009 update => domain%update_E
3010 check => domain%check_E
3012 update => domain%update_N
3013 check => domain%check_N
3016 "mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, CORNER or NORTH")
3019 allocate(overlapList(MAXLIST) )
3020 allocate(checkList(MAXLIST) )
3022 !--- overlap
is used to store the overlapping temporarily.
3023 call allocate_update_overlap( overlap, MAXOVERLAP)
3026 call mpp_get_compute_domain( domain,
isc,
iec,
jsc,
jec, position=position )
3027 call mpp_get_global_domain ( domain,
isg,
ieg,
jsg,
jeg, xsize=ni, ysize=nj, position=position ) !
cyclic offsets
3028 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3029 update%xbegin = ism; update%xend = iem
3030 update%ybegin = jsm; update%yend = jem
3031 if(ASSOCIATED(
check)) then
3035 update%whalo = domain%whalo; update%ehalo = domain%ehalo
3036 update%shalo = domain%shalo; update%nhalo = domain%nhalo
3037 whalo = domain%whalo; ehalo = domain%ehalo
3038 shalo = domain%shalo; nhalo = domain%nhalo
3046 if(.NOT. BTEST(domain%fold,SOUTH)) then
3047 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_south): " 3048 "boundary condition in y-direction should be folded-south for " 3050 if(.NOT. domain%x(tMe)%
cyclic) then
3051 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_south): " 3052 "boundary condition in x-direction should be cyclic for " 3055 if(.
not. domain%symmetry) then
3056 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_south): " 3057 "when south boundary is folded, the domain must be symmetry for " 3063 m = mod( domain%
pos+list, nlist )
3064 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
3065 !
to_pe's eastern halo 3067 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift 3068 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 3069 !--- to make sure the consistence between pes 3070 if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then 3071 !--- do nothing, this point will come from other pe 3073 if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed 3074 is = is-ioff; ie = ie-ioff 3076 !--- when the south face is folded, the east halo point at right side domain will be folded. 3077 !--- the position should be on CORNER or NORTH 3078 if( js == jsg .AND. (position == CORNER .OR. position == NORTH) & 3079 .AND. is .GE. middle .AND. domain%list(m)%x(tNbr)%compute%end+ehalo+jshift .LE. ieg ) then 3080 call insert_update_overlap( overlap, domain%list(m)%pe, & 3081 is, ie, js+1, je, isc, iec, jsc, jec, dir) 3082 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift 3084 select case (position) 3086 i=is; is = isg+ieg-ie; ie = isg+ieg-i 3088 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift 3090 call insert_update_overlap( overlap, domain%list(m)%pe, & 3091 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 3093 call insert_update_overlap( overlap, domain%list(m)%pe, & 3094 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3101 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
3102 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
3111 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3114 !
to_pe's southern halo 3117 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 3118 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 3122 call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je) 3124 !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie, 3125 !--- no need to send, because the data on that point will come from other pe. 3126 !--- come from two pe ( there will be only one point on one pe. ). 3127 if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then 3128 !--- do nothing, this point will come from other pe 3130 call insert_update_overlap( overlap, domain%list(m)%pe, & 3131 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry) 3133 !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER 3134 if(is .LT. isg) then 3136 call insert_update_overlap( overlap, domain%list(m)%pe, & 3137 is, is, js, je, isc, iec, jsc, jec, dir, folded) 3143 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
3144 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
3152 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3154 !--- when
south edge
is folded,
is will be less than
isg when position
is EAST and CORNER
3155 if(
is .LT.
isg) then
3157 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3161 !
to_pe's western halo 3163 is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1 3164 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 3166 !--- to make sure the consistence between pes 3167 if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then 3168 !--- do nothing, this point will come from other pe 3170 if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset 3171 is = is+ioff; ie = ie+ioff 3173 !--- when the south face is folded, some point at j=nj will be folded. 3174 !--- the position should be on CORNER or NORTH 3175 if( js == jsg .AND. (position == CORNER .OR. position == NORTH) & 3176 .AND. ( domain%list(m)%x(tNbr)%compute%begin == isg .OR. domain%list(m)%x(tNbr)%compute%begin-1 .GE. middle)) then 3177 call insert_update_overlap( overlap, domain%list(m)%pe, & 3178 is, ie, js+1, je, isc, iec, jsc, jec, dir) 3179 is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1 3180 js = domain%list(m)%y(tNbr)%compute%begin; je = js 3181 if ( domain%list(m)%x(tNbr)%compute%begin == isg ) then 3182 select case (position) 3184 i=is; is = 2*isg-ie-1; ie = 2*isg-i-1 3186 i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift 3188 if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, & 3189 'mpp_domains_define.inc(compute_overlaps_fold_south):
west edge ubound
error send.
' ) 3191 select case (position) 3193 i=is; is = isg+ieg-ie; ie = isg+ieg-i 3195 i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift 3198 call insert_update_overlap( overlap, domain%list(m)%pe, & 3199 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 3201 call insert_update_overlap( overlap, domain%list(m)%pe, & 3202 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3208 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
3209 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
3213 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3216 !
to_pe's northern halo 3218 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 3219 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 3220 call insert_update_overlap( overlap, domain%list(m)%pe, & 3221 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3225 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
3226 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
3230 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3233 !--- Now calculate the overlapping
for fold-edge.
3234 !--- only position at NORTH and CORNER need to be considered
3235 if( ( position == NORTH .OR. position == CORNER) ) then
3236 if( domain%y(tMe)%data%
begin .LE.
jsg .AND.
jsg .LE. domain%y(tMe)%data%
end+jshift )then !fold
is within domain
3238 !--- calculate the overlapping
for sending 3239 if( domain%x(tMe)%
pos .LT. (
size(domain%x(tMe)%list(:))+1)/2 )then
3241 if(
js ==
jsg )then ! fold
is within domain.
3242 is = domain%list(
m)%x(tNbr)%compute%
begin;
ie = domain%list(
m)%x(tNbr)%compute%
end+ishift
3243 select
case (position)
3251 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3256 nsend_check = nsend_check+1
3257 call allocate_check_overlap(checkList(nsend_check), 1)
3258 call insert_check_overlap(checkList(nsend_check), domain%list(
m)%
pe, &
3259 tMe, 2, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
3267 if( overlap%count > 0) then
3269 if(nsend >
size(overlapList(:)) ) then
3270 call
mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for
send is expanded')
3271 call expand_update_overlap_list(overlapList, nlist)
3273 call add_update_overlap(overlapList(nsend), overlap)
3274 call init_overlap_type(overlap)
3280 unit = mpp_pe() + 1000
3282 write(
unit, *) "********
to_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
3283 do
n = 1, overlapList(
m)%count
3284 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
3285 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
3288 if( nsend > 0) call flush(
unit)
3293 allocate(update%
send(nsend))
3294 update%nsend = nsend
3296 call add_update_overlap( update%
send(
m), overlapList(
m) )
3300 if(nsend_check>0) then
3302 check%nsend = nsend_check
3303 do
m = 1, nsend_check
3304 call add_check_overlap(
check%
send(
m), checkList(
m) )
3308 do
m = 1,
size(overlapList(:))
3309 call deallocate_overlap_type(overlapList(
m))
3313 do
m = 1,
size(checkList(:))
3314 call deallocate_overlap_type(checkList(
m))
3318 isgd =
isg - domain%whalo
3319 iegd =
ieg + domain%ehalo
3320 jsgd =
jsg - domain%shalo
3321 jegd =
jeg + domain%nhalo
3327 m = mod( domain%
pos+nlist-list, nlist )
3328 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
3329 isc = domain%list(
m)%x(1)%compute%
begin;
iec = domain%list(
m)%x(1)%compute%
end+ishift
3330 jsc = domain%list(
m)%y(1)%compute%
begin;
jec = domain%list(
m)%y(1)%compute%
end+jshift
3333 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
3334 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
3336 if( (position == NORTH .OR. position == CORNER ) .AND. (
jsd ==
je .or.
jed ==
js ) ) then
3337 ! --- do nothing, this point
will come from other
pe 3343 !--- when the
south face
is folded, the
east halo point at right side domain
will be folded.
3344 !--- the position should be on CORNER or NORTH
3345 if(
jsd ==
jsg .AND. (position == CORNER .OR. position == NORTH) &
3346 .AND.
isd .GE. middle .AND.
ied .LE.
ieg ) then
3347 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3351 select
case (position)
3357 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3360 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3368 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
3378 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3384 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
3391 if( (position == EAST .OR. position == CORNER ) .AND. (
isd ==
ie .or.
ied ==
is ) ) then
3392 !--- do nothing, this point
will come from other
pe 3394 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3395 is,
ie,
js,
je,
isd,
ied,
jsd,
jed, dir, folded, symmetry=domain%symmetry)
3397 !--- when
south edge
is folded,
is will be less than
isg when position
is EAST and CORNER
3400 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3417 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3419 !--- when southth edge
is folded,
is will be less than
isg when position
is EAST and CORNER
3422 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3429 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
3431 if( (position == NORTH .OR. position == CORNER ) .AND. (
jsd ==
je .or.
jed ==
js ) ) then
3432 ! --- do nothing, this point
will come from other
pe 3438 !--- the position should be on CORNER or NORTH
3439 if(
jsd ==
jsg .AND. (position == CORNER .OR. position == NORTH) &
3440 .AND. (
isd <
isg .OR.
ied .GE. middle ) ) then
3441 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3445 select
case (position)
3453 'mpp_domains_define.inc(compute_overlaps):
west edge ubound
error recv.' )
3455 select
case (position)
3462 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3465 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3473 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
3479 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3484 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
3485 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
3487 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3492 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
3493 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
3498 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3501 !--- Now calculate the overlapping for fold-edge.
3502 !--- for folded-
south-edge, only need to consider
to_pe's
south(3) direction
3503 !--- only position at NORTH and CORNER need to be considered
3504 if( ( position == NORTH .OR. position == CORNER) ) then
3505 if( domain%y(tMe)%data%
begin .LE.
jsg .AND.
jsg .LE. domain%y(tMe)%data%
end+jshift )then !fold
is within domain
3507 !--- calculating overlapping for receving on
north 3508 if( domain%x(tMe)%
pos .GE.
size(domain%x(tMe)%list(:))/2 )then
3510 if(
jsd ==
jsg )then ! fold
is within domain.
3511 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
3513 select
case (position)
3521 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3526 nrecv_check = nrecv_check+1
3527 call allocate_check_overlap(checkList(nrecv_check), 1)
3528 call insert_check_overlap(checkList(nrecv_check), domain%list(
m)%
pe, &
3529 tMe, 2, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
3537 if( overlap%count > 0) then
3539 if(nrecv >
size(overlapList(:)) )then
3540 call
mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for
recv is expanded')
3541 call expand_update_overlap_list(overlapList, nlist)
3543 call add_update_overlap( overlapList(nrecv), overlap)
3544 call init_overlap_type(overlap)
3550 unit = mpp_pe() + 1000
3552 write(
unit, *) "********
from_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
3553 do
n = 1, overlapList(
m)%count
3554 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
3555 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
3558 if(nrecv >0) call flush(
unit)
3563 update%nrecv = nrecv
3564 allocate(update%
recv(nrecv))
3566 call add_update_overlap( update%
recv(
m), overlapList(
m) )
3567 do
n = 1, update%
recv(
m)%count
3568 if(update%
recv(
m)%tileNbr(
n) == domain%tile_id(tMe)) then
3569 if(update%
recv(
m)%dir(
n) == 1) domain%x(tMe)%loffset = 0
3570 if(update%
recv(
m)%dir(
n) == 7) domain%y(tMe)%loffset = 0
3576 if(nrecv_check>0) then
3577 check%nrecv = nrecv_check
3579 do
m = 1, nrecv_check
3580 call add_check_overlap(
check%
recv(
m), checkList(
m) )
3584 call deallocate_overlap_type(overlap)
3586 do
m = 1,
size(overlapList(:))
3587 call deallocate_overlap_type(overlapList(
m))
3591 do
m = 1,
size(checkList(:))
3592 call deallocate_overlap_type(checkList(
m))
3596 deallocate(overlapList)
3597 deallocate(checkList)
3600 domain%initialized = .
true.
3602 end subroutine compute_overlaps_fold_south
3604 !
#################################################################################### 3605 subroutine compute_overlaps_fold_west( domain, position, ishift, jshift)
3606 !computes remote domain overlaps
3607 !assumes only
one in each direction
3608 !
will calculate the overlapping
for T,E,C,N-cell seperately.
3609 type(domain2D), intent(inout) :: domain
3610 integer, intent(in) :: position, ishift, jshift
3613 integer ::
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isd,
ied,
jsd,
jed 3615 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3616 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3618 type(overlap_type) :: overlap
3619 type(overlapSpec), pointer :: update=>
NULL()
3620 type(overlap_type) :: overlapList(MAXLIST)
3621 type(overlap_type) :: checkList(MAXLIST)
3624 integer :: nsend_check, nrecv_check
3627 !--- since we restrict that
if multiple tiles on
one pe, all the tiles are limited to this
pe.
3628 !--- In this
case,
if ntiles on this
pe is greater than 1,
no overlapping between processor within each
tile 3629 !--- In this
case the overlapping exist only for tMe=1 and tNbr=1
3630 if(
size(domain%x(:)) > 1) return
3632 !---
if there
is no halo,
no need to compute overlaps.
3633 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3636 nlist =
size(domain%list(:))
3638 select
case(position)
3640 update => domain%update_T
3643 update => domain%update_C
3644 check => domain%check_C
3646 update => domain%update_E
3647 check => domain%check_E
3649 update => domain%update_N
3650 check => domain%check_N
3653 "mpp_domains_define.inc(compute_overlaps_fold_west): the value of position should be CENTER, EAST, CORNER or NORTH")
3656 !--- overlap
is used to store the overlapping temporarily.
3657 call allocate_update_overlap( overlap, MAXOVERLAP)
3660 call mpp_get_compute_domain( domain,
isc,
iec,
jsc,
jec, position=position )
3661 call mpp_get_global_domain ( domain,
isg,
ieg,
jsg,
jeg, xsize=ni, ysize=nj, position=position ) !
cyclic offsets
3662 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3663 update%xbegin = ism; update%xend = iem
3664 update%ybegin = jsm; update%yend = jem
3665 if(ASSOCIATED(
check)) then
3669 update%whalo = domain%whalo; update%ehalo = domain%ehalo
3670 update%shalo = domain%shalo; update%nhalo = domain%nhalo
3671 whalo = domain%whalo; ehalo = domain%ehalo
3672 shalo = domain%shalo; nhalo = domain%nhalo
3679 if(.NOT. BTEST(domain%fold,WEST)) then
3680 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_west): " 3681 "boundary condition in y-direction should be folded-west for " 3683 if(.NOT. domain%y(tMe)%
cyclic) then
3684 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_west): " 3685 "boundary condition in y-direction should be cyclic for " 3688 if(.
not. domain%symmetry) then
3689 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_west): " 3690 "when west boundary is folded, the domain must be symmetry for " 3696 m = mod( domain%
pos+list, nlist )
3697 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
3698 !
to_pe's eastern halo 3700 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift 3701 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 3702 call insert_update_overlap( overlap, domain%list(m)%pe, & 3703 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3707 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
3708 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
3713 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3716 !
to_pe's southern halo 3718 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 3719 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 3720 !--- to make sure the consistence between pes 3721 if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then 3722 !--- do nothing, this point will come from other pe 3724 if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset 3725 js = js+joff; je = je+joff 3728 !--- when the west face is folded, the south halo points at 3729 !--- the position should be on CORNER or EAST 3730 if( is == isg .AND. (position == CORNER .OR. position == EAST) & 3731 .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle)) then 3732 call insert_update_overlap( overlap, domain%list(m)%pe, & 3733 is+1, ie, js, je, isc, iec, jsc, jec, dir) 3734 is = domain%list(m)%x(tNbr)%compute%begin; ie = is 3735 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 3736 if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then 3737 select case (position) 3739 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1 3741 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift 3743 if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, & 3744 'mpp_domains_define.inc(compute_overlaps_fold_west:
south edge ubound
error send.
' ) 3746 select case (position) 3748 j=js; js = jsg+jeg-je; je = jsg+jeg-j 3750 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift 3753 call insert_update_overlap( overlap, domain%list(m)%pe, & 3754 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 3756 call insert_update_overlap( overlap, domain%list(m)%pe, & 3757 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3764 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
3765 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
3773 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3775 !--- when
south edge
is folded,
js will be less than
jsg when position
is EAST and CORNER
3776 if(
js .LT.
jsg) then
3778 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3782 !
to_pe's western halo 3785 is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1 3786 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 3789 call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je) 3791 !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie, 3792 !--- no need to send, because the data on that point will come from other pe. 3793 !--- come from two pe ( there will be only one point on one pe. ). 3794 if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then 3795 !--- do nothing, this point will come from other pe 3797 call insert_update_overlap( overlap, domain%list(m)%pe, & 3798 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry) 3800 !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER 3801 if(js .LT. jsg) then 3803 call insert_update_overlap( overlap, domain%list(m)%pe, & 3804 is, ie, js, js, isc, iec, jsc, jec, dir, folded) 3810 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
3811 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
3820 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3823 !
to_pe's northern halo 3825 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 3826 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 3827 !--- to make sure the consistence between pes 3828 if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then 3829 !--- do nothing, this point will come from other pe 3831 if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset 3832 js = js-joff; je = je-joff 3834 !--- when the west face is folded, the south halo points at 3835 !--- the position should be on CORNER or EAST 3836 if( is == isg .AND. (position == CORNER .OR. position == EAST) & 3837 .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then 3838 call insert_update_overlap( overlap, domain%list(m)%pe, & 3839 is+1, ie, js, je, isc, iec, jsc, jec, dir) 3840 is = domain%list(m)%x(tNbr)%compute%begin; ie = is 3841 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 3842 select case (position) 3844 j=js; js = jsg+jeg-je; je = jsg+jeg-j 3846 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift 3848 call insert_update_overlap( overlap, domain%list(m)%pe, & 3849 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 3851 call insert_update_overlap( overlap, domain%list(m)%pe, & 3852 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 3858 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
3859 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
3863 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3866 !--- Now calculate the overlapping
for fold-edge.
3867 !--- only position at EAST and CORNER need to be considered
3868 if( ( position == EAST .OR. position == CORNER) ) then
3869 if( domain%x(tMe)%compute%
begin-whalo .LE.
isg .AND.
isg .LE. domain%x(tMe)%data%
end+ishift )then !fold
is within domain
3871 !--- calculate the overlapping
for sending 3872 if( domain%y(tMe)%
pos .LT. (
size(domain%y(tMe)%list(:))+1)/2 )then
3874 if(
is ==
isg )then ! fold
is within domain.
3875 js = domain%list(
m)%y(tNbr)%compute%
begin;
je = domain%list(
m)%y(tNbr)%compute%
end+jshift
3876 select
case (position)
3884 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3889 nsend_check = nsend_check+1
3890 call allocate_check_overlap(checkList(nsend_check), 1)
3891 call insert_check_overlap(checkList(nsend_check), domain%list(
m)%
pe, &
3892 tMe, 3, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
3900 if( overlap%count > 0) then
3903 "mpp_domains_define.inc(compute_overlaps_west): nsend
is greater than MAXLIST, increase MAXLIST")
3904 call add_update_overlap(overlapList(nsend), overlap)
3905 call init_overlap_type(overlap)
3911 unit = mpp_pe() + 1000
3913 write(
unit, *) "********
to_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
3914 do
n = 1, overlapList(
m)%count
3915 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
3916 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
3919 if(nsend >0) call flush(
unit)
3924 update%nsend = nsend
3925 allocate(update%
send(nsend))
3927 call add_update_overlap( update%
send(
m), overlapList(
m) )
3931 if(nsend_check>0) then
3932 check%nsend = nsend_check
3934 do
m = 1, nsend_check
3935 call add_check_overlap(
check%
send(
m), checkList(
m) )
3940 call deallocate_overlap_type(overlapList(
m))
3944 isgd =
isg - domain%whalo
3945 iegd =
ieg + domain%ehalo
3946 jsgd =
jsg - domain%shalo
3947 jegd =
jeg + domain%nhalo
3953 m = mod( domain%
pos+nlist-list, nlist )
3954 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
3955 isc = domain%list(
m)%x(1)%compute%
begin;
iec = domain%list(
m)%x(1)%compute%
end+ishift
3956 jsc = domain%list(
m)%y(1)%compute%
begin;
jec = domain%list(
m)%y(1)%compute%
end+jshift
3959 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
3960 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
3962 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3967 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
3973 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
3979 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
3983 if( (position == EAST .OR. position == CORNER ) .AND. (
isd ==
ie .or.
ied ==
is ) ) then
3984 !--- do nothing, this point
will come from other
pe 3989 !--- when the
west face
is folded, the
south halo points at
3990 !--- the position should be on CORNER or EAST
3991 if(
isd ==
isg .AND. (position == CORNER .OR. position == EAST) &
3992 .AND. (
jsd <
jsg .OR.
jed .GE. middle ) ) then
3993 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
3997 select
case (position)
4004 'mpp_domains_define.inc(compute_overlaps_fold_west:
south edge ubound
error recv.' )
4006 select
case (position)
4013 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4016 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4034 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4036 !--- when
west edge
is folded,
js will be less than
jsg when position
is EAST and CORNER
4039 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4047 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
4053 if( (position == EAST .OR. position == CORNER ) .AND. (
jsd ==
je .or.
jed ==
js ) ) then
4054 !--- do nothing, this point
will come from other
pe 4056 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4057 is,
ie,
js,
je,
isd,
ied,
jsd,
jed, dir, folded, symmetry=domain%symmetry)
4059 !--- when
west edge
is folded,
js will be less than
jsg when position
is EAST and CORNER
4062 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4070 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4080 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4086 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
4087 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4089 if( (position == EAST .OR. position == CORNER ) .AND. (
isd ==
ie .or.
ied ==
is ) ) then
4090 !--- do nothing, this point
will come from other
pe 4095 !--- when the
west face
is folded, the
south halo points at
4096 !--- the position should be on CORNER or EAST
4097 if(
isd ==
isg .AND. (position == CORNER .OR. position == EAST) &
4098 .AND.
jsd .GE. middle .AND.
jed .LE.
jeg ) then
4099 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4102 select
case (position)
4108 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4111 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4118 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
4119 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4124 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4127 !--- Now calculate the overlapping for fold-edge.
4128 !--- for folded-
south-edge, only need to consider
to_pe's
south(3) direction
4129 !--- only position at EAST and CORNER need to be considered
4130 if( ( position == EAST .OR. position == CORNER) ) then
4131 if( domain%x(tMe)%data%
begin .LE.
isg .AND.
isg .LE. domain%x(tMe)%data%
end+ishift )then !fold
is within domain
4133 !--- calculating overlapping for receving on
north 4134 if( domain%y(tMe)%
pos .GE.
size(domain%y(tMe)%list(:))/2 )then
4136 if(
isd ==
isg )then ! fold
is within domain.
4137 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
4139 select
case (position)
4147 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4152 nrecv_check = nrecv_check+1
4153 call allocate_check_overlap(checkList(nrecv_check), 1)
4154 call insert_check_overlap(checkList(nrecv_check), domain%list(
m)%
pe, &
4155 tMe, 3, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
4163 if( overlap%count > 0) then
4166 "mpp_domains_define.inc(compute_overlaps_west): nrecv
is greater than MAXLIST, increase MAXLIST")
4167 call add_update_overlap( overlapList(nrecv), overlap)
4168 call init_overlap_type(overlap)
4174 unit = mpp_pe() + 1000
4176 write(
unit, *) "********
from_pe = " ,overlapList(
m)%
pe, " count = ",overlapList(
m)%count
4177 do
n = 1, overlapList(
m)%count
4178 write(
unit, *) overlapList(
m)%
is(
n), overlapList(
m)%
ie(
n), overlapList(
m)%
js(
n), overlapList(
m)%
je(
n), &
4179 overlapList(
m)%dir(
n), overlapList(
m)%rotation(
n)
4182 if(nrecv >0) call flush(
unit)
4187 update%nrecv = nrecv
4188 allocate(update%
recv(nrecv))
4190 call add_update_overlap( update%
recv(
m), overlapList(
m) )
4191 do
n = 1, update%
recv(
m)%count
4192 if(update%
recv(
m)%tileNbr(
n) == domain%tile_id(tMe)) then
4193 if(update%
recv(
m)%dir(
n) == 1) domain%x(tMe)%loffset = 0
4194 if(update%
recv(
m)%dir(
n) == 7) domain%y(tMe)%loffset = 0
4200 if(nrecv_check>0) then
4201 check%nrecv = nrecv_check
4203 do
m = 1, nrecv_check
4204 call add_check_overlap(
check%
recv(
m), checkList(
m) )
4208 call deallocate_overlap_type(overlap)
4210 call deallocate_overlap_type(overlapList(
m))
4216 domain%initialized = .
true.
4218 end subroutine compute_overlaps_fold_west
4220 !
############################################################################### 4221 subroutine compute_overlaps_fold_east( domain, position, ishift, jshift )
4222 !computes remote domain overlaps
4223 !assumes only
one in each direction
4224 !
will calculate the overlapping
for T,E,C,N-cell seperately.
4225 !here assume fold-
east and y-
cyclic boundary condition
4226 type(domain2D), intent(inout) :: domain
4227 integer, intent(in) :: position, ishift, jshift
4230 integer ::
is,
ie,
js,
je,
isc,
iec,
jsc,
jec,
isd,
ied,
jsd 4232 integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
4233 integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
4235 type(overlap_type) :: overlap
4236 type(overlapSpec), pointer :: update=>
NULL()
4237 type(overlap_type) :: overlapList(MAXLIST)
4238 type(overlap_type) :: checkList(MAXLIST)
4241 integer :: nsend_check, nrecv_check
4243 !--- since we restrict that
if multiple tiles on
one pe, all the tiles are limited to this
pe.
4244 !--- In this
case,
if ntiles on this
pe is greater than 1,
no overlapping between processor within each
tile 4245 !--- In this
case the overlapping exist only for tMe=1 and tNbr=1
4246 if(
size(domain%x(:)) > 1) return
4248 !---
if there
is no halo,
no need to compute overlaps.
4249 if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
4252 nlist =
size(domain%list(:))
4254 select
case(position)
4256 update => domain%update_T
4258 update => domain%update_C
4259 check => domain%check_C
4261 update => domain%update_E
4262 check => domain%check_E
4264 update => domain%update_N
4265 check => domain%check_N
4268 "mpp_domains_define.inc(compute_overlaps_fold_east): the value of position should be CENTER, EAST, CORNER or NORTH")
4271 !--- overlap
is used to store the overlapping temporarily.
4272 call allocate_update_overlap( overlap, MAXOVERLAP)
4275 call mpp_get_compute_domain( domain,
isc,
iec,
jsc,
jec, position=position )
4276 call mpp_get_global_domain ( domain,
isg,
ieg,
jsg,
jeg, xsize=ni, ysize=nj, position=position ) !
cyclic offsets
4277 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
4278 update%xbegin = ism; update%xend = iem
4279 update%ybegin = jsm; update%yend = jem
4280 if(ASSOCIATED(
check)) then
4284 update%whalo = domain%whalo; update%ehalo = domain%ehalo
4285 update%shalo = domain%shalo; update%nhalo = domain%nhalo
4286 whalo = domain%whalo; ehalo = domain%ehalo
4287 shalo = domain%shalo; nhalo = domain%nhalo
4294 if(.NOT. BTEST(domain%fold,EAST)) then
4295 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_east): " 4296 "boundary condition in y-direction should be folded-east for " 4298 if(.NOT. domain%y(tMe)%
cyclic) then
4299 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_east): " 4300 "boundary condition in y-direction should be cyclic for " 4302 if(.
not. domain%symmetry) then
4303 call
mpp_error(FATAL,
"mpp_domains_define.inc(compute_overlaps_fold_east): " 4304 "when east boundary is folded, the domain must be symmetry for " 4310 m = mod( domain%
pos+list, nlist )
4311 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
4312 !
to_pe's eastern halo 4315 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift 4316 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 4319 call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je) 4321 !--- when domain symmetry and position is EAST or CORNER, the point when jsc == je, 4322 !--- no need to send, because the data on that point will come from other pe. 4323 !--- come from two pe ( there will be only one point on one pe. ). 4324 if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then 4325 !--- do nothing, this point will come from other pe 4327 call insert_update_overlap( overlap, domain%list(m)%pe, & 4328 is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry) 4330 !--- when east edge is folded, js .LT. jsg 4331 if(js .LT. jsg) then 4333 call insert_update_overlap( overlap, domain%list(m)%pe, & 4334 is, ie, js, js, isc, iec, jsc, jec, dir, folded) 4340 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
4341 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
4351 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4353 !--- when
east edge
is folded,
4354 if(
js .LT.
jsg) then
4356 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4360 !
to_pe's southern halo 4362 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 4363 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 4364 !--- to make sure the consistence between pes 4365 if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then 4366 !--- do nothing, this point will come from other pe 4368 if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset 4369 js = js+joff; je = je+joff 4371 !--- when the east face is folded, the south halo points at 4372 !--- the position should be on CORNER or EAST 4373 if( ie == ieg .AND. (position == CORNER .OR. position == EAST) & 4374 .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. & 4375 domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle ) ) then 4376 call insert_update_overlap( overlap, domain%list(m)%pe, & 4377 is, ie-1, js, je, isc, iec, jsc, jec, dir) 4378 !--- consider at i = ieg for east edge. 4379 !--- when the data is at corner and not symmetry, j = jsg -1 will get from cyclic condition 4380 if(position == CORNER .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tNbr)%compute%begin == jsg) then 4381 call insert_update_overlap(overlap, domain%list(m)%pe, & 4382 ie, ie, je, je, isc, iec, jsc, jec, dir, .true.) 4385 ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie 4386 js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1 4387 if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then 4388 select case (position) 4390 j=js; js = 2*jsg-je-1; je = 2*jsg-j-1 4392 j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift 4394 if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, & 4395 'mpp_domains_define.inc(compute_overlaps_fold_east:
south edge ubound
error send.
' ) 4397 select case (position) 4399 j=js; js = jsg+jeg-je; je = jsg+jeg-j 4401 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift 4404 call insert_update_overlap( overlap, domain%list(m)%pe, & 4405 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 4407 call insert_update_overlap( overlap, domain%list(m)%pe, & 4408 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 4414 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
4415 js = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
je = domain%list(
m)%y(tNbr)%compute%
begin-1
4419 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4422 !
to_pe's western halo 4424 is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1 4425 js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift 4426 call insert_update_overlap( overlap, domain%list(m)%pe, & 4427 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 4431 is = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ie = domain%list(
m)%x(tNbr)%compute%
begin-1
4432 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
4436 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4439 !
to_pe's northern halo 4442 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift 4443 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 4444 !--- to make sure the consistence between pes 4445 if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then 4446 !--- do nothing, this point will come from other pe 4448 if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset 4449 js = js-joff; je = je-joff 4451 !--- when the east face is folded, the north halo points at 4452 !--- the position should be on CORNER or EAST 4453 if( ie == ieg .AND. (position == CORNER .OR. position == EAST) & 4454 .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then 4455 call insert_update_overlap( overlap, domain%list(m)%pe, & 4456 is, ie-1, js, je, isc, iec, jsc, jec, dir) 4457 ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie 4458 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift 4459 select case (position) 4461 j=js; js = jsg+jeg-je; je = jsg+jeg-j 4463 j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift 4465 call insert_update_overlap( overlap, domain%list(m)%pe, & 4466 is, ie, js, je, isc, iec, jsc, jec, dir, .true.) 4468 call insert_update_overlap( overlap, domain%list(m)%pe, & 4469 is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry) 4476 is = domain%list(
m)%x(tNbr)%compute%
end+1+ishift;
ie = domain%list(
m)%x(tNbr)%compute%
end+ehalo+ishift
4477 js = domain%list(
m)%y(tNbr)%compute%
end+1+jshift;
je = domain%list(
m)%y(tNbr)%compute%
end+nhalo+jshift
4486 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4489 !--- Now calculate the overlapping
for fold-edge.
4490 !--- only position at EAST and CORNER need to be considered
4491 if( ( position == EAST .OR. position == CORNER) ) then
4492 if( domain%x(tMe)%data%
begin .LE.
ieg .AND.
ieg .LE. domain%x(tMe)%data%
end+ishift )then !fold
is within domain
4494 !--- calculate the overlapping
for sending 4495 if( domain%y(tMe)%
pos .LT. (
size(domain%y(tMe)%list(:))+1)/2 )then
4496 ie = domain%list(
m)%x(tNbr)%compute%
end+ishift;
is =
ie 4497 if(
ie ==
ieg )then ! fold
is within domain.
4498 js = domain%list(
m)%y(tNbr)%compute%
begin;
je = domain%list(
m)%y(tNbr)%compute%
end+jshift
4499 select
case (position)
4507 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4512 nsend_check = nsend_check+1
4513 call allocate_check_overlap(checkList(nsend_check), 1)
4514 call insert_check_overlap(checkList(nsend_check), domain%list(
m)%
pe, &
4515 tMe, 1, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
4523 if( overlap%count > 0) then
4526 "mpp_domains_define.inc(compute_overlaps_east): nsend
is greater than MAXLIST, increase MAXLIST")
4527 call add_update_overlap(overlapList(nsend), overlap)
4528 call init_overlap_type(overlap)
4534 update%nsend = nsend
4535 allocate(update%
send(nsend))
4537 call add_update_overlap( update%
send(
m), overlapList(
m) )
4541 if(nsend_check>0) then
4542 check%nsend = nsend_check
4544 do
m = 1, nsend_check
4545 call add_check_overlap(
check%
send(
m), checkList(
m) )
4550 call deallocate_overlap_type(overlapList(
m))
4554 isgd =
isg - domain%whalo
4555 iegd =
ieg + domain%ehalo
4556 jsgd =
jsg - domain%shalo
4557 jegd =
jeg + domain%nhalo
4563 m = mod( domain%
pos+nlist-list, nlist )
4564 if(domain%list(
m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within
tile.
4565 isc = domain%list(
m)%x(1)%compute%
begin;
iec = domain%list(
m)%x(1)%compute%
end+ishift
4566 jsc = domain%list(
m)%y(1)%compute%
begin;
jec = domain%list(
m)%y(1)%compute%
end+jshift
4570 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
4571 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
4577 if( (position == EAST .OR. position == CORNER ) .AND. (
jsd ==
je .or.
jed ==
js ) ) then
4578 !--- do nothing, this point
will come from other
pe 4580 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4581 is,
ie,
js,
je,
isd,
ied,
jsd,
jed, dir, folded, symmetry=domain%symmetry)
4583 !--- when
west edge
is folded,
js will be less than
jsg when position
is EAST and CORNER
4586 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4593 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
4603 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4605 !--- when
west edge
is folded,
js will be less than
jsg when position
is EAST and CORNER
4608 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4615 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
4619 if( (position == EAST .OR. position == CORNER ) .AND. (
isd ==
ie .or.
ied ==
is ) ) then
4620 !--- do nothing, this point
will come from other
pe 4625 !--- when the
east face
is folded, the
south halo points at
4626 !--- the position should be on CORNER or EAST
4627 if(
ied ==
ieg .AND. (position == CORNER .OR. position == EAST) &
4628 .AND. (
jsd <
jsg .OR.
jed .GE. middle ) ) then
4629 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4633 select
case (position)
4640 'mpp_domains_define.inc(compute_overlaps_fold_west:
south edge ubound
error recv.' )
4642 select
case (position)
4649 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4652 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4665 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4671 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
4673 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4680 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4685 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4691 isd = domain%x(tMe)%compute%
begin;
ied = domain%x(tMe)%compute%
end+ishift
4692 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4694 if( (position == EAST .OR. position == CORNER ) .AND. (
isd ==
ie .or.
ied ==
is ) ) then
4695 !--- do nothing, this point
will come from other
pe 4700 !--- when the
east face
is folded, the
south halo points at
4701 !--- the position should be on CORNER or EAST
4702 if(
ied ==
ieg .AND. (position == CORNER .OR. position == EAST) &
4703 .AND.
jsd .GE. middle .AND.
jed .LE.
jeg ) then
4704 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4707 select
case (position)
4713 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4716 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4724 isd = domain%x(tMe)%compute%
end+1+ishift;
ied = domain%x(tMe)%data%
end+ishift
4725 jsd = domain%y(tMe)%compute%
end+1+jshift;
jed = domain%y(tMe)%data%
end+jshift
4735 call insert_update_overlap( overlap, domain%list(
m)%
pe, &
4737 !--- Now calculate the overlapping for fold-edge.
4738 !--- for folded-
south-edge, only need to consider
to_pe's
south(3) direction
4739 !--- only position at EAST and CORNER need to be considered
4740 if( ( position == EAST .OR. position == CORNER) ) then
4741 if( domain%x(tMe)%data%
begin .LE.
ieg .AND.
ieg .LE. domain%x(tMe)%data%
end+ishift )then !fold
is within domain
4743 !--- calculating overlapping for receving on
north 4744 if( domain%y(tMe)%
pos .GE.
size(domain%y(tMe)%list(:))/2 )then
4746 if(
ied ==
ieg )then ! fold
is within domain.
4747 jsd = domain%y(tMe)%compute%
begin;
jed = domain%y(tMe)%compute%
end+jshift
4749 select
case (position)
4757 call insert_update_overlap(overlap, domain%list(
m)%
pe, &
4762 nrecv_check = nrecv_check+1
4763 call allocate_check_overlap(checkList(nrecv_check), 1)
4764 call insert_check_overlap(checkList(nrecv_check), domain%list(
m)%
pe, &
4765 tMe, 3, ONE_HUNDRED_EIGHTY,
is,
ie,
js,
je)
4773 if( overlap%count > 0) then
4776 "mpp_domains_define.inc(compute_overlaps_east): nrecv
is greater than MAXLIST, increase MAXLIST")
4777 call add_update_overlap( overlapList(nrecv), overlap)
4778 call init_overlap_type(overlap)
4784 update%nrecv = nrecv
4785 allocate(update%
recv(nrecv))
4787 call add_update_overlap( update%
recv(
m), overlapList(
m) )
4788 do
n = 1, update%
recv(
m)%count
4789 if(update%
recv(
m)%tileNbr(
n) == domain%tile_id(tMe)) then
4790 if(update%
recv(
m)%dir(
n) == 1) domain%x(tMe)%loffset = 0
4791 if(update%
recv(
m)%dir(
n) == 7) domain%y(tMe)%loffset = 0
4797 if(nrecv_check>0) then
4798 check%nrecv = nrecv_check
4800 do
m = 1, nrecv_check
4801 call add_check_overlap(
check%
recv(
m), checkList(
m) )
4805 call deallocate_overlap_type(overlap)
4807 call deallocate_overlap_type(overlapList(
m))
4814 domain%initialized = .
true.
4816 end subroutine compute_overlaps_fold_east
4818 !
##################################################################################### 4824 select
case(position)
4839 end subroutine get_fold_index_west
4841 !#####################################################################################
4847 select
case(position)
4862 end subroutine get_fold_index_east
4864 !#####################################################################################
4865 subroutine get_fold_index_south(
isg,
ieg,
jsg, ishift, position,
is,
ie,
js,
je)
4870 select
case(position)
4885 end subroutine get_fold_index_south
4886 !#####################################################################################
4887 subroutine get_fold_index_north(
isg,
ieg,
jeg, ishift, position,
is,
ie,
js,
je)
4892 select
case(position)
4907 end subroutine get_fold_index_north
4910 !#####################################################################################
4912 subroutine apply_cyclic_offset(lstart, lend,
offset, gstart, gend, gsize)
4913 integer, intent(inout) :: lstart, lend
4917 if(lstart > gend) lstart = lstart - gsize
4918 if(lstart < gstart) lstart = lstart + gsize
4920 if(lend > gend) lend = lend - gsize
4921 if(lend < gstart) lend = lend + gsize
4925 end subroutine apply_cyclic_offset
4927 !###################################################################################
4928 ! this routine setup the overlapping for mpp_update_domains for arbitrary halo update.
4929 ! should be the halo
size defined in mpp_define_domains.
4930 ! xhalo_out, yhalo_out should
not be exactly the same as xhalo_in, yhalo_in
4931 ! currently we didn
't consider about tripolar grid situation, because in the folded north 4932 ! region, the overlapping is specified through list of points, not through rectangular. 4933 ! But will return back to solve this problem in the future. 4934 subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out) 4935 type(domain2d), intent(in) :: domain 4936 type(overlapSpec), intent(in) :: overlap_in 4937 type(overlapSpec), intent(inout) :: overlap_out 4938 integer, intent(in) :: whalo_out, ehalo_out, shalo_out, nhalo_out 4939 integer :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation 4940 integer :: whalo_in, ehalo_in, shalo_in, nhalo_in 4942 type(overlap_type) :: overlap 4943 type(overlap_type), allocatable :: send(:), recv(:) 4944 type(overlap_type), pointer :: ptrIn => NULL() 4945 integer :: nsend, nrecv, nsend_in, nrecv_in 4947 if( domain%fold .NE. 0) call mpp_error(FATAL, & 4948 "mpp_domains_define.inc(set_overlaps): folded domain is not implemented for arbitrary halo update, contact developer") 4950 whalo_in = domain%whalo 4951 ehalo_in = domain%ehalo 4952 shalo_in = domain%shalo 4953 nhalo_in = domain%nhalo 4955 if( .NOT. domain%initialized) call mpp_error(FATAL, & 4956 "mpp_domains_define.inc: domain is not defined yet") 4958 nlist = size(domain%list(:)) 4959 isoff = whalo_in - abs(whalo_out) 4960 ieoff = ehalo_in - abs(ehalo_out) 4961 jsoff = shalo_in - abs(shalo_out) 4962 jeoff = nhalo_in - abs(nhalo_out) 4965 nsend_in = overlap_in%nsend 4966 nrecv_in = overlap_in%nrecv 4967 if(nsend_in>0) allocate(send(nsend_in)) 4968 if(nrecv_in>0) allocate(recv(nrecv_in)) 4969 call allocate_update_overlap(overlap, MAXOVERLAP) 4971 overlap_out%whalo = whalo_out 4972 overlap_out%ehalo = ehalo_out 4973 overlap_out%shalo = shalo_out 4974 overlap_out%nhalo = nhalo_out 4975 overlap_out%xbegin = overlap_in%xbegin 4976 overlap_out%xend = overlap_in%xend 4977 overlap_out%ybegin = overlap_in%ybegin 4978 overlap_out%yend = overlap_in%yend 4979 !--- setting up overlap. 4981 ptrIn => overlap_in%send(m) 4982 if(ptrIn%count .LE. 0) call mpp_error(FATAL, & 4983 "mpp_domains_define.inc(set_overlaps): number of overlap for send should be a positive number for"//trim(domain%name) ) 4984 do n = 1, ptrIn%count 4986 rotation = ptrIn%rotation(n) 4988 case(1) ! to_pe's eastern halo
4989 if(ehalo_out > 0) then
4990 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0,
n, dir, rotation)
4991 else
if(ehalo_out<0) then
4992 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0,
n, dir, rotation)
4995 if(ehalo_out>0 .AND. shalo_out > 0) then 4996 call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation) 4997 else if(ehalo_out<0 .AND. shalo_out < 0) then ! three parts: southeast, south and east. 4998 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation) 4999 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation) 5000 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation) 5002 case(3) ! to_pe's southern halo
5003 if(shalo_out > 0) then
5004 call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0,
n, dir, rotation)
5005 else
if(shalo_out<0) then
5006 call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out,
n, dir, rotation)
5009 if(whalo_out>0 .AND. shalo_out > 0) then 5010 call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir, rotation) 5011 else if(whalo_out<0 .AND. shalo_out < 0) then 5012 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation) 5013 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation) 5014 call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation) 5016 case(5) ! to_pe's western halo
5017 if(whalo_out > 0) then
5018 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0,
n, dir, rotation)
5019 else
if(whalo_out<0) then
5020 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0,
n, dir, rotation)
5023 if(whalo_out>0 .AND. nhalo_out > 0) then 5024 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir, rotation) 5025 else if(whalo_out<0 .AND. nhalo_out < 0) then 5026 call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation) 5027 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation) 5028 call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation) 5030 case(7) ! to_pe's northern halo
5031 if(nhalo_out > 0) then
5032 call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff,
n, dir, rotation)
5033 else
if(nhalo_out<0) then
5034 call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0,
n, dir, rotation)
5037 if(ehalo_out>0 .AND. nhalo_out > 0) then 5038 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation) 5039 else if(ehalo_out<0 .AND. nhalo_out < 0) then 5040 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation) 5041 call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation) 5042 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation) 5045 end do ! do n = 1, ptrIn%count 5046 if(overlap%count>0) then 5048 call add_update_overlap(send(nsend), overlap) 5049 call init_overlap_type(overlap) 5051 end do ! end do list = 0, nlist-1 5054 overlap_out%nsend = nsend 5055 allocate(overlap_out%send(nsend)); 5057 call add_update_overlap(overlap_out%send(n), send(n) ) 5060 overlap_out%nsend = 0 5063 !-------------------------------------------------- 5065 !--------------------------------------------------- 5069 ptrIn => overlap_in%recv(m) 5070 if(ptrIn%count .LE. 0) call mpp_error(FATAL, & 5071 "mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number") 5073 do n = 1, ptrIn%count 5075 rotation = ptrIn%rotation(n) 5077 case(1) ! eastern halo 5078 if(ehalo_out > 0) then 5079 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir) 5080 else if(ehalo_out<0) then 5081 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir) 5083 case(2) ! southeast halo 5084 if(ehalo_out>0 .AND. shalo_out > 0) then 5085 call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir) 5086 else if(ehalo_out<0 .AND. shalo_out < 0) then 5087 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir) 5088 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1) 5089 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1) 5091 case(3) ! southern halo 5092 if(shalo_out > 0) then 5093 call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir) 5094 else if(shalo_out<0) then 5095 call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir) 5097 case(4) ! southwest halo 5098 if(whalo_out>0 .AND. shalo_out > 0) then 5099 call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir) 5100 else if(whalo_out<0 .AND. shalo_out < 0) then 5101 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir) 5102 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1) 5103 call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1) 5105 case(5) ! western halo 5106 if(whalo_out > 0) then 5107 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir) 5108 else if(whalo_out<0) then 5109 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir) 5111 case(6) ! northwest halo 5112 if(whalo_out>0 .AND. nhalo_out > 0) then 5113 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir) 5114 else if(whalo_out<0 .AND. nhalo_out < 0) then 5115 call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir) 5116 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1) 5117 call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1) 5119 case(7) ! northern halo 5120 if(nhalo_out > 0) then 5121 call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir) 5122 else if(nhalo_out<0) then 5123 call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir) 5125 case(8) ! northeast halo 5126 if(ehalo_out>0 .AND. nhalo_out > 0) then 5127 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir) 5128 else if(ehalo_out<0 .AND. nhalo_out < 0) then 5129 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir) 5130 call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1) 5131 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1) 5134 end do ! do n = 1, ptrIn%count 5135 if(overlap%count>0) then 5137 call add_update_overlap(recv(nrecv), overlap) 5138 call init_overlap_type(overlap) 5140 end do ! end do list = 0, nlist-1 5142 overlap_out%nrecv = nrecv 5143 allocate(overlap_out%recv(nrecv)); 5145 call add_update_overlap(overlap_out%recv(n), recv(n) ) 5148 overlap_out%nrecv = 0 5151 call deallocate_overlap_type(overlap) 5153 call deallocate_overlap_type(send(n)) 5156 call deallocate_overlap_type(recv(n)) 5158 if(allocated(send)) deallocate(send) 5159 if(allocated(recv)) deallocate(recv) 5162 call set_domain_comm_inf(overlap_out) 5165 end subroutine set_overlaps 5167 !############################################################################## 5168 subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation) 5169 type(overlap_type), intent(in) :: overlap_in 5170 type(overlap_type), intent(inout) :: overlap_out 5171 integer, intent(in) :: isoff, jsoff, ieoff, jeoff 5172 integer, intent(in) :: index 5173 integer, intent(in) :: dir 5174 integer, optional, intent(in) :: rotation 5178 if( overlap_out%pe == NULL_PE ) then 5179 overlap_out%pe = overlap_in%pe 5181 if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, & 5182 "mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out") 5185 if(isoff .NE. 0 .and. ieoff .NE. 0) call mpp_error(FATAL, & 5186 "mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero") 5187 if(jsoff .NE. 0 .and. jeoff .NE. 0) call mpp_error(FATAL, & 5188 "mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero") 5191 overlap_out%count = overlap_out%count + 1 5192 count = overlap_out%count 5193 if(count > MAXOVERLAP) call mpp_error(FATAL, & 5194 "set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP") 5196 if(present(rotation)) rotate = rotation 5197 overlap_out%rotation (count) = overlap_in%rotation(index) 5198 overlap_out%dir (count) = dir 5199 overlap_out%tileMe (count) = overlap_in%tileMe(index) 5200 overlap_out%tileNbr (count) = overlap_in%tileNbr(index) 5204 overlap_out%is(count) = overlap_in%is(index) + isoff 5205 overlap_out%ie(count) = overlap_in%ie(index) + ieoff 5206 overlap_out%js(count) = overlap_in%js(index) + jsoff 5207 overlap_out%je(count) = overlap_in%je(index) + jeoff 5209 overlap_out%is(count) = overlap_in%is(index) - jeoff 5210 overlap_out%ie(count) = overlap_in%ie(index) - jsoff 5211 overlap_out%js(count) = overlap_in%js(index) + isoff 5212 overlap_out%je(count) = overlap_in%je(index) + ieoff 5214 overlap_out%is(count) = overlap_in%is(index) + jsoff 5215 overlap_out%ie(count) = overlap_in%ie(index) + jeoff 5216 overlap_out%js(count) = overlap_in%js(index) - ieoff 5217 overlap_out%je(count) = overlap_in%je(index) - isoff 5219 call mpp_error(FATAL, "mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY") 5223 end subroutine set_single_overlap 5225 !################################################################################### 5226 !--- compute the overlapping between tiles for the T-cell. 5227 subroutine define_contact_point( domain, position, num_contact, tile1, tile2, align1, align2, & 5228 refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, & 5229 isgList, iegList, jsgList, jegList ) 5230 type(domain2D), intent(inout) :: domain 5231 integer, intent(in) :: position 5232 integer, intent(in) :: num_contact ! number of contact regions 5233 integer, dimension(:), intent(in) :: tile1, tile2 ! tile number 5234 integer, dimension(:), intent(in) :: align1, align2 ! align direction of contact region 5235 real, dimension(:), intent(in) :: refine1, refine2 ! refinement between tiles 5236 integer, dimension(:), intent(in) :: istart1, iend1 ! i-index in tile_1 of contact region 5237 integer, dimension(:), intent(in) :: jstart1, jend1 ! j-index in tile_1 of contact region 5238 integer, dimension(:), intent(in) :: istart2, iend2 ! i-index in tile_2 of contact region 5239 integer, dimension(:), intent(in) :: jstart2, jend2 ! j-index in tile_2 of contact region 5240 integer, dimension(:), intent(in) :: isgList, iegList ! i-global domain of each tile 5241 integer, dimension(:), intent(in) :: jsgList, jegList ! j-global domain of each tile 5243 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed 5244 integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2 5245 integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2 5246 integer :: is, ie, js, je, ioff, joff, isoff, ieoff, jsoff, jeoff 5247 integer :: ntiles, max_contact 5248 integer :: nlist, list, m, n, l, count, numS, numR 5249 integer :: whalo, ehalo, shalo, nhalo 5250 integer :: t1, t2, tt, pos 5251 integer :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir 5252 integer :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem 5253 integer :: dirlist(8) 5254 !--- is2Send and is1Send will figure out the overlapping for sending from current pe. 5255 !--- is1Recv and iscREcv will figure out the overlapping for recving onto current pe. 5256 integer, dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send 5257 integer, dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send 5258 integer, dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv 5259 integer, dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv 5260 integer, dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send 5261 real, dimension(4*num_contact) :: refineRecv, refineSend 5262 integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv 5263 integer :: nsend, nrecv, nsend2, nrecv2 5264 type(contact_type), dimension(domain%ntiles) :: eCont, wCont, sCont, nCont 5265 type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv 5268 if( position .NE. CENTER ) call mpp_error(FATAL, "mpp_domains_define.inc: " //& 5269 "routine define_contact_point can only be used to calculate overlapping for cell center.") 5271 ntiles = domain%ntiles 5273 eCont(:)%ncontact = 0; 5276 eCont(n)%ncontact = 0; sCont(n)%ncontact = 0; wCont(n)%ncontact = 0; nCont(n)%ncontact = 0; 5277 allocate(eCont(n)%tile(num_contact), wCont(n)%tile(num_contact) ) 5278 allocate(nCont(n)%tile(num_contact), sCont(n)%tile(num_contact) ) 5279 allocate(eCont(n)%align1(num_contact), eCont(n)%align2(num_contact) ) 5280 allocate(wCont(n)%align1(num_contact), wCont(n)%align2(num_contact) ) 5281 allocate(sCont(n)%align1(num_contact), sCont(n)%align2(num_contact) ) 5282 allocate(nCont(n)%align1(num_contact), nCont(n)%align2(num_contact) ) 5283 allocate(eCont(n)%refine1(num_contact), eCont(n)%refine2(num_contact) ) 5284 allocate(wCont(n)%refine1(num_contact), wCont(n)%refine2(num_contact) ) 5285 allocate(sCont(n)%refine1(num_contact), sCont(n)%refine2(num_contact) ) 5286 allocate(nCont(n)%refine1(num_contact), nCont(n)%refine2(num_contact) ) 5287 allocate(eCont(n)%is1(num_contact), eCont(n)%ie1(num_contact), eCont(n)%js1(num_contact), eCont(n)%je1(num_contact)) 5288 allocate(eCont(n)%is2(num_contact), eCont(n)%ie2(num_contact), eCont(n)%js2(num_contact), eCont(n)%je2(num_contact)) 5289 allocate(wCont(n)%is1(num_contact), wCont(n)%ie1(num_contact), wCont(n)%js1(num_contact), wCont(n)%je1(num_contact)) 5290 allocate(wCont(n)%is2(num_contact), wCont(n)%ie2(num_contact), wCont(n)%js2(num_contact), wCont(n)%je2(num_contact)) 5291 allocate(sCont(n)%is1(num_contact), sCont(n)%ie1(num_contact), sCont(n)%js1(num_contact), sCont(n)%je1(num_contact)) 5292 allocate(sCont(n)%is2(num_contact), sCont(n)%ie2(num_contact), sCont(n)%js2(num_contact), sCont(n)%je2(num_contact)) 5293 allocate(nCont(n)%is1(num_contact), nCont(n)%ie1(num_contact), nCont(n)%js1(num_contact), nCont(n)%je1(num_contact)) 5294 allocate(nCont(n)%is2(num_contact), nCont(n)%ie2(num_contact), nCont(n)%js2(num_contact), nCont(n)%je2(num_contact)) 5297 !--- set up the east, south, west and north contact for each tile. 5298 do n = 1, num_contact 5301 select case(align1(n)) 5303 call fill_contact( eCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), & 5304 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n)) 5306 call fill_contact( wCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), & 5307 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n)) 5309 call fill_contact( sCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), & 5310 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n)) 5312 call fill_contact( nCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), & 5313 jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n)) 5315 select case(align2(n)) 5317 call fill_contact( eCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), & 5318 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n)) 5320 call fill_contact( wCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), & 5321 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n)) 5323 call fill_contact( sCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), & 5324 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n)) 5326 call fill_contact( nCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), & 5327 jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n)) 5331 !--- the tile number of current pe, halo size 5332 whalo = domain%whalo 5333 ehalo = domain%ehalo 5334 shalo = domain%shalo 5335 nhalo = domain%nhalo 5337 !--- find if there is an extra point in x and y direction depending on position 5338 nlist = size(domain%list(:)) 5340 max_contact = 4*num_contact ! should be enough 5342 ntileMe = size(domain%x(:)) 5343 refineSend = 1; refineRecv = 1 5345 !-------------------------------------------------------------------------------------------------- 5346 ! loop over each tile on current domain to set up the overlapping for each tile 5347 !-------------------------------------------------------------------------------------------------- 5348 !--- first check the overlap within the tiles. 5349 do n = 1, domain%update_T%nsend 5350 pos = domain%update_T%send(n)%pe - mpp_root_pe() 5351 call add_update_overlap(overlapSend(pos), domain%update_T%send(n) ) 5353 do n = 1, domain%update_T%nrecv 5354 pos = domain%update_T%recv(n)%pe - mpp_root_pe() 5355 call add_update_overlap(overlapRecv(pos), domain%update_T%recv(n) ) 5358 call mpp_get_memory_domain(domain, ism, iem, jsm, jem) 5359 domain%update_T%xbegin = ism; domain%update_T%xend = iem 5360 domain%update_T%ybegin = jsm; domain%update_T%yend = jem 5361 domain%update_T%whalo = whalo; domain%update_T%ehalo = ehalo 5362 domain%update_T%shalo = shalo; domain%update_T%nhalo = nhalo 5365 tileMe = domain%tile_id(tMe) 5366 rotateSend = ZERO; rotateRecv = ZERO 5368 !--- loop over all the contact region to figure out the index for overlapping region. 5370 do n = 1, eCont(tileMe)%ncontact ! east contact 5372 tileRecv(count) = eCont(tileMe)%tile(n); tileSend(count) = eCont(tileMe)%tile(n) 5373 align1Recv(count) = eCont(tileMe)%align1(n); align2Recv(count) = eCont(tileMe)%align2(n) 5374 align1Send(count) = eCont(tileMe)%align1(n); align2Send(count) = eCont(tileMe)%align2(n) 5375 refineSend(count) = eCont(tileMe)%refine2(n); refineRecv(count) = eCont(tileMe)%refine1(n) 5376 is1Recv(count) = eCont(tileMe)%is1(n) + 1; ie1Recv(count) = is1Recv(count) + ehalo - 1 5377 js1Recv(count) = eCont(tileMe)%js1(n); je1Recv(count) = eCont(tileMe)%je1(n) 5378 select case(eCont(tileMe)%align2(n)) 5379 case ( WEST ) ! w <-> e 5380 is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = is2Recv(count) + ehalo - 1 5381 js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = eCont(tileMe)%je2(n) 5382 ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - whalo + 1 5383 js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n) 5384 ie2Send(count) = eCont(tileMe)%is2(n) - 1; is2Send(count) = ie2Send(count) - whalo + 1 5385 js2Send(count) = eCont(tileMe)%js2(n); je2Send(count) = eCont(tileMe)%je2(n) 5386 case ( SOUTH ) ! s <-> e 5387 rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY 5388 js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + ehalo -1 5389 is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = eCont(tileMe)%ie2(n) 5390 ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - shalo + 1 5391 js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n) 5392 is2Send(count) = eCont(tileMe)%is2(n); ie2Send(count) = eCont(tileMe)%ie2(n) 5393 je2Send(count) = eCont(tileMe)%js2(n) - 1; js2Send(count) = je2Send(count) - shalo + 1 5397 do n = 1, sCont(tileMe)%ncontact ! south contact 5399 tileRecv(count) = sCont(tileMe)%tile(n); tileSend(count) = sCont(tileMe)%tile(n) 5400 align1Recv(count) = sCont(tileMe)%align1(n); align2Recv(count) = sCont(tileMe)%align2(n); 5401 align1Send(count) = sCont(tileMe)%align1(n); align2Send(count) = sCont(tileMe)%align2(n); 5402 refineSend(count) = sCont(tileMe)%refine2(n); refineRecv(count) = sCont(tileMe)%refine1(n) 5403 is1Recv(count) = sCont(tileMe)%is1(n); ie1Recv(count) = sCont(tileMe)%ie1(n) 5404 je1Recv(count) = sCont(tileMe)%js1(n) - 1; js1Recv(count) = je1Recv(count) - shalo + 1 5405 select case(sCont(tileMe)%align2(n)) 5406 case ( NORTH ) ! n <-> s 5407 is2Recv(count) = sCont(tileMe)%is2(n); ie2Recv(count) = sCont(tileMe)%ie2(n) 5408 je2Recv(count) = sCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - shalo + 1 5409 is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n) 5410 js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + nhalo -1 5411 is2Send(count) = sCont(tileMe)%is2(n); ie2Send(count) = sCont(tileMe)%ie2(n) 5412 js2Send(count) = sCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1 5413 case ( EAST ) ! e <-> s 5414 rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY 5415 ie2Recv(count) = sCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - shalo + 1 5416 js2Recv(count) = sCont(tileMe)%js2(n); je2Recv(count) = sCont(tileMe)%je2(n) 5417 is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n) 5418 js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + ehalo - 1 5419 is2Send(count) = sCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1 5420 js2Send(count) = sCont(tileMe)%js2(n); je2Send(count) = sCont(tileMe)%je2(n) 5424 do n = 1, wCont(tileMe)%ncontact ! west contact 5426 tileRecv(count) = wCont(tileMe)%tile(n); tileSend(count) = wCont(tileMe)%tile(n) 5427 align1Recv(count) = wCont(tileMe)%align1(n); align2Recv(count) = wCont(tileMe)%align2(n); 5428 align1Send(count) = wCont(tileMe)%align1(n); align2Send(count) = wCont(tileMe)%align2(n); 5429 refineSend(count) = wCont(tileMe)%refine2(n); refineRecv(count) = wCont(tileMe)%refine1(n) 5430 ie1Recv(count) = wCont(tileMe)%is1(n) - 1; is1Recv(count) = ie1Recv(count) - whalo + 1 5431 js1Recv(count) = wCont(tileMe)%js1(n); je1Recv(count) = wCont(tileMe)%je1(n) 5432 select case(wCont(tileMe)%align2(n)) 5433 case ( EAST ) ! e <-> w 5434 ie2Recv(count) = wCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - whalo + 1 5435 js2Recv(count) = wCont(tileMe)%js2(n); je2Recv(count) = wCont(tileMe)%je2(n) 5436 is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + ehalo - 1 5437 js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n) 5438 is2Send(count) = wCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1 5439 js2Send(count) = wCont(tileMe)%js2(n); je2Send(count) = wCont(tileMe)%je2(n) 5440 case ( NORTH ) ! n <-> w 5441 rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY 5442 je2Recv(count) = wCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - whalo + 1 5443 is2Recv(count) = wCont(tileMe)%is2(n); ie2Recv(count) = wCont(tileMe)%ie2(n) 5444 is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + nhalo - 1 5445 js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n) 5446 js2Send(count) = wCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1 5447 is2Send(count) = wCont(tileMe)%is2(n); ie2Send(count) = wCont(tileMe)%ie2(n) 5451 do n = 1, nCont(tileMe)%ncontact ! north contact 5453 tileRecv(count) = nCont(tileMe)%tile(n); tileSend(count) = nCont(tileMe)%tile(n) 5454 align1Recv(count) = nCont(tileMe)%align1(n); align2Recv(count) = nCont(tileMe)%align2(n); 5455 align1Send(count) = nCont(tileMe)%align1(n); align2Send(count) = nCont(tileMe)%align2(n); 5456 refineSend(count) = nCont(tileMe)%refine2(n); refineRecv(count) = nCont(tileMe)%refine1(n) 5457 is1Recv(count) = nCont(tileMe)%is1(n); ie1Recv(count) = nCont(tileMe)%ie1(n) 5458 js1Recv(count) = nCont(tileMe)%je1(n)+1; je1Recv(count) = js1Recv(count) + nhalo - 1 5459 select case(nCont(tileMe)%align2(n)) 5460 case ( SOUTH ) ! s <-> n 5461 is2Recv(count) = nCont(tileMe)%is2(n); ie2Recv(count) = nCont(tileMe)%ie2(n) 5462 js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + nhalo - 1 5463 is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n) 5464 je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - shalo + 1 5465 is2Send(count) = nCont(tileMe)%is2(n); ie2Send(count) = nCont(tileMe)%ie2(n) 5466 je2Send(count) = nCont(tileMe)%js2(n)-1; js2Send(count) = je2Send(count) - shalo + 1 5467 case ( WEST ) ! w <-> n 5468 rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY 5469 is2Recv(count) = nCont(tileMe)%ie2(n); ie2Recv(count) = is2Recv(count) + nhalo - 1 5470 js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = nCont(tileMe)%je2(n) 5471 is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n) 5472 je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - whalo + 1 5473 ie2Send(count) = nCont(tileMe)%is2(n)-1; is2Send(count) = ie2Send(count) - whalo + 1 5474 js2Send(count) = nCont(tileMe)%js2(n); je2Send(count) = nCont(tileMe)%je2(n) 5480 !--- figure out the index for corner overlapping, 5481 !--- fill_corner_contact will be updated to deal with the situation that there are multiple tiles on 5482 !--- each side of six sides of cubic grid. 5483 if(.NOT. domain%rotated_ninety) then 5484 call fill_corner_contact(eCont, sCont, wCont, nCont, isgList, iegList, jsgList, jegList, numR, numS, & 5485 tileRecv, tileSend, is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, & 5486 js2Recv, je2Recv, is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, & 5487 js2Send, je2Send, align1Recv, align2Recv, align1Send, align2Send, & 5488 whalo, ehalo, shalo, nhalo, tileMe ) 5491 isc = domain%x(tMe)%compute%begin; iec = domain%x(tMe)%compute%end 5492 jsc = domain%y(tMe)%compute%begin; jec = domain%y(tMe)%compute%end 5494 !--- compute the overlapping for send. 5496 do list = 0, nlist-1 5497 m = mod( domain%pos+list, nlist ) 5498 ntileNbr = size(domain%list(m)%x(:)) 5499 do tNbr = 1, ntileNbr 5500 if( domain%list(m)%tile_id(tNbr) .NE. tileSend(n) ) cycle 5501 isc1 = max(isc, is1Send(n)); iec1 = min(iec, ie1Send(n)) 5502 jsc1 = max(jsc, js1Send(n)); jec1 = min(jec, je1Send(n)) 5503 if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle 5504 !--- loop over 8 direction to get the overlapping starting from east with clockwise. 5506 !--- get the to_pe's data domain.
5508 case ( 1 ) ! eastern halo
5509 if( align2Send(
n) .NE. EAST ) cycle
5510 isd = domain%list(
m)%x(tNbr)%compute%
end+1;
ied = domain%list(
m)%x(tNbr)%compute%
end+ehalo
5511 jsd = domain%list(
m)%y(tNbr)%compute%
begin;
jed = domain%list(
m)%y(tNbr)%compute%
end 5512 case ( 2 ) ! southeast halo
5513 isd = domain%list(
m)%x(tNbr)%compute%
end+1;
ied = domain%list(
m)%x(tNbr)%compute%
end+ehalo
5514 jsd = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
jed = domain%list(
m)%y(tNbr)%compute%
begin-1
5515 case ( 3 ) ! southern halo
5516 if( align2Send(
n) .NE. SOUTH ) cycle
5517 isd = domain%list(
m)%x(tNbr)%compute%
begin;
ied = domain%list(
m)%x(tNbr)%compute%
end 5518 jsd = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
jed = domain%list(
m)%y(tNbr)%compute%
begin-1
5519 case ( 4 ) ! southwest halo
5520 isd = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ied = domain%list(
m)%x(tNbr)%compute%
begin-1
5521 jsd = domain%list(
m)%y(tNbr)%compute%
begin-shalo;
jed = domain%list(
m)%y(tNbr)%compute%
begin-1
5522 case ( 5 ) ! western halo
5523 if( align2Send(
n) .NE. WEST ) cycle
5524 isd = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ied = domain%list(
m)%x(tNbr)%compute%
begin-1
5525 jsd = domain%list(
m)%y(tNbr)%compute%
begin;
jed = domain%list(
m)%y(tNbr)%compute%
end 5526 case ( 6 ) ! northwest halo
5527 isd = domain%list(
m)%x(tNbr)%compute%
begin-whalo;
ied = domain%list(
m)%x(tNbr)%compute%
begin-1
5528 jsd = domain%list(
m)%y(tNbr)%compute%
end+1;
jed = domain%list(
m)%y(tNbr)%compute%
end+nhalo
5529 case ( 7 ) ! northern halo
5530 if( align2Send(
n) .NE. NORTH ) cycle
5531 isd = domain%list(
m)%x(tNbr)%compute%
begin;
ied = domain%list(
m)%x(tNbr)%compute%
end 5532 jsd = domain%list(
m)%y(tNbr)%compute%
end+1;
jed = domain%list(
m)%y(tNbr)%compute%
end+nhalo
5533 case ( 8 ) ! northeast halo
5534 isd = domain%list(
m)%x(tNbr)%compute%
end+1;
ied = domain%list(
m)%x(tNbr)%compute%
end+ehalo
5535 jsd = domain%list(
m)%y(tNbr)%compute%
end+1;
jed = domain%list(
m)%y(tNbr)%compute%
end+nhalo
5543 select
case ( align2Send(
n) )
5545 ioff =
isd - is2Send(
n)
5546 joff =
jsd - js2Send(
n)
5547 case ( SOUTH, NORTH )
5548 ioff =
isd - is2Send(
n)
5549 joff =
jsd - js2Send(
n)
5552 !---
get the index in current
pe.
5553 select
case ( rotateSend(
n) )
5555 isc2 = is1Send(
n) + ioff; iec2 = isc2 + nxd - 1
5556 jsc2 = js1Send(
n) + joff; jec2 = jsc2 + nyd - 1
5557 case ( NINETY ) ! N -> W or S -> E
5558 iec2 = ie1Send(
n) - joff; isc2 = iec2 - nyd + 1
5559 jsc2 = js1Send(
n) + ioff; jec2 = jsc2 + nxd - 1
5560 case ( MINUS_NINETY ) ! W -> N or E -> S
5561 isc2 = is1Send(
n) + joff; iec2 = isc2 + nyd - 1
5562 jec2 = je1Send(
n) - ioff; jsc2 = jec2 - nxd + 1
5566 if(
ie.GE.is .AND.
je.GE.js )then
5567 if(.
not. associated(overlapSend(
m)%tileMe)) call allocate_update_overlap(overlapSend(
m), MAXOVERLAP)
5568 call insert_overlap_type(overlapSend(
m), domain%list(
m)%
pe, tMe, tNbr, &
5569 is,
ie,
js,
je, dir, rotateSend(
n), .
true. )
5571 end do !
end do dir = 1, 8
5572 end do !
end do tNbr = 1, ntileNbr
5573 end do !
end do list = 0, nlist-1
5576 !--- compute the overlapping for
recv.
5578 do list = 0, nlist-1
5579 m = mod( domain%
pos+nlist-list, nlist )
5580 ntileNbr =
size(domain%list(
m)%x(:))
5581 do tNbr = 1, ntileNbr
5582 if( domain%list(
m)%tile_id(tNbr) .NE. tileRecv(
n) ) cycle
5583 isc = domain%list(
m)%x(tNbr)%compute%
begin;
iec = domain%list(
m)%x(tNbr)%compute%
end 5584 jsc = domain%list(
m)%y(tNbr)%compute%
begin;
jec = domain%list(
m)%y(tNbr)%compute%
end 5588 !--- find the
offset for this overlapping.
5591 select
case ( align2Recv(
n) )
5593 if(align2Recv(
n) == WEST) then
5594 ioff =
isc - is2Recv(
n)
5596 ioff = ie2Recv(
n) -
iec 5598 joff =
jsc - js2Recv(
n)
5599 case ( NORTH, SOUTH )
5600 ioff =
isc - is2Recv(
n)
5601 if(align2Recv(
n) == SOUTH) then
5602 joff =
jsc - js2Recv(
n)
5604 joff = je2Recv(
n) -
jec 5608 !--- get the index in current
pe.
5609 select
case ( rotateRecv(
n) )
5611 isd1 = is1Recv(
n) + ioff; ied1 = isd1 + nxc - 1
5612 jsd1 = js1Recv(
n) + joff; jed1 = jsd1 + nyc - 1
5613 if( align1Recv(
n) == WEST ) then
5614 ied1 = ie1Recv(
n)-ioff; isd1 = ied1 - nxc + 1
5616 if( align1Recv(
n) == SOUTH ) then
5617 jed1 = je1Recv(
n)-joff; jsd1 = jed1 - nyc + 1
5619 case ( NINETY ) ! N -> W or S -> E
5620 if( align1Recv(
n) == WEST ) then
5621 ied1 = ie1Recv(
n)-joff; isd1 = ied1 - nyc + 1
5623 isd1 = is1Recv(
n)+joff; ied1 = isd1 + nyc - 1
5625 jed1 = je1Recv(
n) - ioff; jsd1 = jed1 - nxc + 1
5626 case ( MINUS_NINETY ) ! W -> N or E -> S
5627 ied1 = ie1Recv(
n) - joff; isd1 = ied1 - nyc + 1
5628 if( align1Recv(
n) == SOUTH ) then
5629 jed1 = je1Recv(
n)-ioff; jsd1 = jed1 - nxc + 1
5631 jsd1 = js1Recv(
n)+ioff; jed1 = jsd1 + nxc - 1
5635 !--- loop over 8 direction to get the overlapping starting from
east with clockwise.
5638 case ( 1 ) ! eastern halo
5639 if( align1Recv(
n) .NE. EAST ) cycle
5640 isd2 = domain%x(tMe)%compute%
end+1; ied2 = domain%x(tMe)%data%
end 5641 jsd2 = domain%y(tMe)%compute%
begin; jed2 = domain%y(tMe)%compute%
end 5642 case ( 2 ) ! southeast halo
5643 isd2 = domain%x(tMe)%compute%
end+1; ied2 = domain%x(tMe)%data%
end 5644 jsd2 = domain%y(tMe)%data%
begin; jed2 = domain%y(tMe)%compute%
begin-1
5645 case ( 3 ) ! southern halo
5646 if( align1Recv(
n) .NE. SOUTH ) cycle
5647 isd2 = domain%x(tMe)%compute%
begin; ied2 = domain%x(tMe)%compute%
end 5648 jsd2 = domain%y(tMe)%data%
begin; jed2 = domain%y(tMe)%compute%
begin-1
5649 case ( 4 ) ! southwest halo
5650 isd2 = domain%x(tMe)%data%
begin; ied2 = domain%x(tMe)%compute%
begin-1
5651 jsd2 = domain%y(tMe)%data%
begin; jed2 = domain%y(tMe)%compute%
begin-1
5652 case ( 5 ) ! western halo
5653 if( align1Recv(
n) .NE. WEST ) cycle
5654 isd2 = domain%x(tMe)%data%
begin; ied2 = domain%x(tMe)%compute%
begin-1
5655 jsd2 = domain%y(tMe)%compute%
begin; jed2 = domain%y(tMe)%compute%
end 5656 case ( 6 ) ! northwest halo
5657 isd2 = domain%x(tMe)%data%
begin; ied2 = domain%x(tMe)%compute%
begin-1
5658 jsd2 = domain%y(tMe)%compute%
end+1; jed2 = domain%y(tMe)%data%
end 5659 case ( 7 ) ! northern halo
5660 if( align1Recv(
n) .NE. NORTH ) cycle
5661 isd2 = domain%x(tMe)%compute%
begin; ied2 = domain%x(tMe)%compute%
end 5662 jsd2 = domain%y(tMe)%compute%
end+1; jed2 = domain%y(tMe)%data%
end 5663 case ( 8 ) ! northeast halo
5664 isd2 = domain%x(tMe)%compute%
end+1; ied2 = domain%x(tMe)%data%
end 5665 jsd2 = domain%y(tMe)%compute%
end+1; jed2 = domain%y(tMe)%data%
end 5670 if(.
not. associated(overlapRecv(
m)%tileMe)) call allocate_update_overlap(overlapRecv(
m), MAXOVERLAP)
5671 call insert_overlap_type(overlapRecv(
m), domain%list(
m)%
pe, tMe, tNbr, &
5673 count = overlapRecv(
m)%count
5675 end do !
end do dir = 1, 8
5676 end do !
end do tNbr = 1, ntileNbr
5677 end do !
end do list = 0, nlist-1
5679 end do !
end do tMe = 1, ntileMe
5682 nsend = 0; nsend2 = 0
5683 do list = 0, nlist-1
5684 m = mod( domain%
pos+list, nlist )
5685 if(overlapSend(
m)%count>0) nsend = nsend + 1
5690 unit = mpp_pe() + 1000
5691 do list = 0, nlist-1
5692 m = mod( domain%
pos+list, nlist )
5693 if(overlapSend(
m)%count==0) cycle
5694 write(
unit, *) "********
to_pe = " ,overlapSend(
m)%
pe, " count = ",overlapSend(
m)%count
5695 do
n = 1, overlapSend(
m)%count
5696 write(
unit, *) overlapSend(
m)%
is(
n), overlapSend(
m)%
ie(
n), overlapSend(
m)%
js(
n), overlapSend(
m)%
je(
n), &
5697 overlapSend(
m)%dir(
n), overlapSend(
m)%rotation(
n)
5700 if(nsend >0) call flush(
unit)
5703 dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
5704 dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
5708 if(associated(domain%update_T%
send)) then
5709 do
m = 1, domain%update_T%nsend
5710 call deallocate_overlap_type(domain%update_T%
send(
m))
5712 deallocate(domain%update_T%
send)
5714 domain%update_T%nsend = nsend
5715 allocate(domain%update_T%
send(nsend))
5716 do list = 0, nlist-1
5717 m = mod( domain%
pos+list, nlist )
5718 ntileNbr =
size(domain%list(
m)%x(:))
5719 !--- for the
send, the list should be in tileNbr
order and dir
order to be consistent with Recv
5720 if(overlapSend(
m)%count > 0) then
5723 "mpp_domains_define.inc(define_contact_point): nsend2
is greater than nsend")
5724 call allocate_update_overlap(domain%update_T%
send(nsend2), overlapSend(
m)%count)
5726 do tNbr = 1, ntileNbr
5728 if(domain%list(
m)%
pe == domain%
pe) then ! own processor
5730 if(tMe > ntileMe) tMe = tMe - ntileMe
5734 do
n = 1, 8 ! loop over 8 direction
5735 do l = 1, overlapSend(
m)%count
5736 if(overlapSend(
m)%tileMe(l) .NE. tMe) cycle
5737 if(overlapSend(
m)%tileNbr(l) .NE. tNbr) cycle
5738 if(overlapSend(
m)%dir(l) .NE. dirlist(
n) ) cycle
5739 call insert_overlap_type(domain%update_T%
send(nsend2), overlapSend(
m)%
pe, &
5740 overlapSend(
m)%tileMe(l), overlapSend(
m)%tileNbr(l), overlapSend(
m)%
is(l), overlapSend(
m)%
ie(l), &
5741 overlapSend(
m)%
js(l), overlapSend(
m)%
je(l), overlapSend(
m)%dir(l), overlapSend(
m)%rotation(l), &
5742 overlapSend(
m)%from_contact(l) )
5752 "mpp_domains_define.inc(define_contact_point): nsend2 does
not equal to nsend")
5754 nrecv = 0; nrecv2 = 0
5755 do list = 0, nlist-1
5756 m = mod( domain%
pos+list, nlist )
5757 if(overlapRecv(
m)%count>0) nrecv = nrecv + 1
5761 do list = 0, nlist-1
5762 m = mod( domain%
pos+list, nlist )
5763 if(overlapRecv(
m)%count==0) cycle
5764 write(
unit, *) "********
from_pe = " ,overlapRecv(
m)%
pe, " count = ",overlapRecv(
m)%count
5765 do
n = 1, overlapRecv(
m)%count
5766 write(
unit, *) overlapRecv(
m)%
is(
n), overlapRecv(
m)%
ie(
n), overlapRecv(
m)%
js(
n), overlapRecv(
m)%
je(
n), &
5767 overlapRecv(
m)%dir(
n), overlapRecv(
m)%rotation(
n)
5770 if(nrecv >0) call flush(
unit)
5774 if(associated(domain%update_T%
recv)) then
5775 do
m = 1, domain%update_T%nrecv
5776 call deallocate_overlap_type(domain%update_T%
recv(
m))
5778 deallocate(domain%update_T%
recv)
5780 domain%update_T%nrecv = nrecv
5781 allocate(domain%update_T%
recv(nrecv))
5783 do list = 0, nlist-1
5784 m = mod( domain%
pos+nlist-list, nlist )
5785 ntileNbr =
size(domain%list(
m)%x(:))
5786 if(overlapRecv(
m)%count > 0) then
5789 "mpp_domains_define.inc(define_contact_point): nrecv2
is greater than nrecv")
5790 call allocate_update_overlap(domain%update_T%
recv(nrecv2), overlapRecv(
m)%count)
5793 !--- make sure the same
order tile for different
pe count
5794 if(domain%list(
m)%
pe == domain%
pe) then ! own processor
5796 if(tNbr>ntileNbr) tNbr = tNbr - ntileNbr
5800 do
n = 1, 8 ! loop over 8 direction
5801 do l = 1, overlapRecv(
m)%count
5802 if(overlapRecv(
m)%tileMe(l) .NE. tMe) cycle
5803 if(overlapRecv(
m)%tileNbr(l) .NE. tNbr) cycle
5804 if(overlapRecv(
m)%dir(l) .NE. dirlist(
n) ) cycle
5805 call insert_overlap_type(domain%update_T%
recv(nrecv2), overlapRecv(
m)%
pe, &
5806 overlapRecv(
m)%tileMe(l), overlapRecv(
m)%tileNbr(l), overlapRecv(
m)%
is(l), overlapRecv(
m)%
ie(l), &
5807 overlapRecv(
m)%
js(l), overlapRecv(
m)%
je(l), overlapRecv(
m)%dir(l), overlapRecv(
m)%rotation(l), &
5808 overlapRecv(
m)%from_contact(l))
5809 count = domain%update_T%
recv(nrecv2)%count
5819 "mpp_domains_define.inc(define_contact_point): nrecv2 does
not equal to nrecv")
5822 call deallocate_overlap_type(overlapSend(
m))
5823 call deallocate_overlap_type(overlapRecv(
m))
5828 deallocate(eCont(
n)%align1, wCont(
n)%align1, sCont(
n)%align1, nCont(
n)%align1)
5829 deallocate(eCont(
n)%align2, wCont(
n)%align2, sCont(
n)%align2, nCont(
n)%align2)
5830 deallocate(eCont(
n)%refine1, wCont(
n)%refine1, sCont(
n)%refine1, nCont(
n)%refine1)
5831 deallocate(eCont(
n)%refine2, wCont(
n)%refine2, sCont(
n)%refine2, nCont(
n)%refine2)
5832 deallocate(eCont(
n)%is1, eCont(
n)%ie1, eCont(
n)%js1, eCont(
n)%je1 )
5833 deallocate(eCont(
n)%is2, eCont(
n)%ie2, eCont(
n)%js2, eCont(
n)%je2 )
5834 deallocate(wCont(
n)%is1, wCont(
n)%ie1, wCont(
n)%js1, wCont(
n)%je1 )
5835 deallocate(wCont(
n)%is2, wCont(
n)%ie2, wCont(
n)%js2, wCont(
n)%je2 )
5836 deallocate(sCont(
n)%is1, sCont(
n)%ie1, sCont(
n)%js1, sCont(
n)%je1 )
5837 deallocate(sCont(
n)%is2, sCont(
n)%ie2, sCont(
n)%js2, sCont(
n)%je2 )
5838 deallocate(nCont(
n)%is1, nCont(
n)%ie1, nCont(
n)%js1, nCont(
n)%je1 )
5839 deallocate(nCont(
n)%is2, nCont(
n)%ie2, nCont(
n)%js2, nCont(
n)%je2 )
5842 domain%initialized = .
true.
5845 end subroutine define_contact_point
5847 !
############################################################################## 5848 !--- always
fill the contact according to index
order.
5849 subroutine fill_contact(Contact,
tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
5850 type(contact_type), intent(inout) :: Contact
5852 integer, intent(in) :: is1, ie1, js1, je1
5853 integer, intent(in) :: is2, ie2, js2, je2
5854 integer, intent(in) :: align1, align2
5855 real, intent(in) :: refine1, refine2
5858 do
pos = 1, Contact%ncontact
5861 if( js1 < Contact%js1(
pos) ) exit
5863 if( is1 < Contact%is1(
pos) ) exit
5867 Contact%ncontact = Contact%ncontact + 1
5868 do
n = Contact%ncontact,
pos+1, -1 ! shift the data
if needed.
5870 Contact%align1(
n) = Contact%align1(
n-1)
5871 Contact%align2(
n) = Contact%align2(
n-1)
5872 Contact%is1(
n) = Contact%is1(
n-1); Contact%ie1(
n) = Contact%ie1(
n-1)
5873 Contact%js1(
n) = Contact%js1(
n-1); Contact%je1(
n) = Contact%je1(
n-1)
5874 Contact%is2(
n) = Contact%is2(
n-1); Contact%ie2(
n) = Contact%ie2(
n-1)
5875 Contact%js2(
n) = Contact%js2(
n-1); Contact%je2(
n) = Contact%je2(
n-1)
5879 Contact%align1(
pos) = align1
5880 Contact%align2(
pos) = align2
5881 Contact%refine1(
pos) = refine1
5882 Contact%refine2(
pos) = refine2
5883 Contact%is1(
pos) = is1; Contact%ie1(
pos) = ie1
5884 Contact%js1(
pos) = js1; Contact%je1(
pos) = je1
5885 Contact%is2(
pos) = is2; Contact%ie2(
pos) = ie2
5886 Contact%js2(
pos) = js2; Contact%je2(
pos) = je2
5888 end subroutine fill_contact
5890 !
############################################################################ 5891 !
this routine sets the overlapping between tiles
for E,C,N-cell based on
T-cell overlapping
5892 subroutine set_contact_point(domain, position)
5893 type(domain2d), intent(inout) :: domain
5894 integer, intent(in) :: position
5896 integer :: ishift, jshift, nlist, list,
m,
n 5897 integer :: ntileMe, tMe, dir, count,
pos, nsend, nrecv
5898 integer :: isoff1, ieoff1, isoff2, ieoff2, jsoff1, jeoff1, jsoff2, jeoff2
5899 type(overlap_type), pointer :: ptrIn =>
NULL()
5900 type(overlapSpec), pointer :: update_in =>
NULL()
5901 type(overlapSpec), pointer :: update_out =>
NULL()
5902 type(overlap_type) :: overlapList(0:
size(domain%list(:))-1)
5903 type(overlap_type) :: overlap
5905 call mpp_get_domain_shift(domain, ishift, jshift, position)
5906 update_in => domain%update_T
5907 select
case(position)
5909 update_out => domain%update_C
5911 update_out => domain%update_E
5913 update_out => domain%update_N
5915 call
mpp_error(FATAL,
"mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
5918 update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
5919 update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
5920 update_out%whalo = update_in%whalo; update_out%ehalo = update_in%ehalo
5921 update_out%shalo = update_in%shalo; update_out%nhalo = update_in%nhalo
5923 nlist =
size(domain%list(:))
5924 ntileMe =
size(domain%x(:))
5925 call allocate_update_overlap(overlap, MAXOVERLAP)
5927 call init_overlap_type(overlapList(
m))
5931 nsend = update_out%nsend
5934 call add_update_overlap(overlapList(
pos), update_out%
send(
m))
5935 call deallocate_overlap_type(update_out%
send(
m))
5937 if(ASSOCIATED(update_out%
send) )deallocate(update_out%
send)
5939 !--- loop over the list of overlapping.
5940 nsend = update_in%nsend
5942 ptrIn => update_in%
send(
m)
5943 pos = PtrIn%
pe - mpp_root_pe()
5944 do
n = 1, ptrIn%count
5946 ! only
set overlapping between tiles for
send ( ptrOut%overlap(1)
is false )
5947 if(ptrIn%from_contact(
n)) then
5950 select
case(ptrIn%rotation(
n))
5951 case (ZERO) ! W -> E
5952 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
5953 case (NINETY) ! S -> E
5954 isoff1 = 0; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5957 select
case(ptrIn%rotation(
n))
5959 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
5961 isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5963 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5966 select
case(ptrIn%rotation(
n))
5967 case (ZERO) ! N -> S
5968 isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
5969 case (MiNUS_NINETY) ! E -> S
5970 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = ishift
5973 select
case(ptrIn%rotation(
n))
5975 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5977 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
5979 isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
5982 select
case(ptrIn%rotation(
n))
5983 case (ZERO) ! E -> W
5984 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
5985 case (NINETY) ! N -> W
5986 isoff1 = 0; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
5989 select
case(ptrIn%rotation(
n))
5991 isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
5993 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5995 isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5998 select
case(ptrIn%rotation(
n))
5999 case (ZERO) ! S -> N
6000 isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6001 case (MINUS_NINETY) ! W -> N
6002 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = ishift
6005 select
case(ptrIn%rotation(
n))
6007 isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6009 isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6011 isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6014 call insert_overlap_type(overlap, PtrIn%
pe, PtrIn%tileMe(
n), PtrIn%tileNbr(
n), &
6015 Ptrin%
is(
n) + isoff1, Ptrin%
ie(
n) + ieoff1, Ptrin%
js(
n) + jsoff1, &
6016 Ptrin%
je(
n) + jeoff1, PtrIn%dir(
n), PtrIn%rotation(
n), PtrIn%from_contact(
n))
6018 end do ! do
n = 1, prtIn%count
6019 if(overlap%count > 0) then
6020 call add_update_overlap(overlapList(
pos), overlap)
6021 call init_overlap_type(overlap)
6023 end do ! do list = 0, nlist-1
6026 do list = 0, nlist-1
6027 m = mod( domain%
pos+list, nlist )
6028 if(overlapList(
m)%count>0) nsend = nsend+1
6031 update_out%nsend = nsend
6033 allocate(update_out%
send(nsend))
6035 do list = 0, nlist-1
6036 m = mod( domain%
pos+list, nlist )
6037 if(overlapList(
m)%count>0) then
6040 "mpp_domains_define.inc(set_contact_point):
pos should be
no larger than nsend")
6041 call add_update_overlap(update_out%
send(
pos), overlapList(
m))
6042 call deallocate_overlap_type(overlapList(
m))
6046 "mpp_domains_define.inc(set_contact_point):
pos should
equal to nsend")
6052 nrecv = update_out%nrecv
6055 call add_update_overlap(overlapList(
pos), update_out%
recv(
m))
6056 call deallocate_overlap_type(update_out%
recv(
m))
6058 if(ASSOCIATED(update_out%
recv) )deallocate(update_out%
recv)
6060 !--- loop over the list of overlapping.
6061 nrecv = update_in%nrecv
6063 ptrIn => update_in%
recv(
m)
6064 pos = PtrIn%
pe - mpp_root_pe()
6065 do
n = 1, ptrIn%count
6067 ! only
set overlapping between tiles for
recv ( ptrOut%overlap(1)
is false )
6068 if(ptrIn%from_contact(
n)) then
6071 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6073 isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6075 isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6077 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6079 isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6081 isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6083 isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6085 isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
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))
6090 count = overlap%count
6092 end do ! do
n = 1, ptrIn%count
6093 if(overlap%count > 0) then
6094 call add_update_overlap(overlapList(
pos), overlap)
6095 call init_overlap_type(overlap)
6097 do tMe = 1,
size(domain%x(:))
6098 do
n = 1, overlap%count
6099 if(overlap%tileMe(
n) == tMe) then
6100 if(overlap%dir(
n) == 1 ) domain%x(tMe)%loffset = 0
6101 if(overlap%dir(
n) == 7 ) domain%y(tMe)%loffset = 0
6105 end do ! do list = 0, nlist-1
6108 do list = 0, nlist-1
6109 m = mod( domain%
pos+nlist-list, nlist )
6110 if(overlapList(
m)%count>0) nrecv = nrecv+1
6113 update_out%nrecv = nrecv
6115 allocate(update_out%
recv(nrecv))
6117 do list = 0, nlist-1
6118 m = mod( domain%
pos+nlist-list, nlist )
6119 if(overlapList(
m)%count>0) then
6122 "mpp_domains_define.inc(set_contact_point):
pos should be
no larger than nrecv")
6123 call add_update_overlap(update_out%
recv(
pos), overlapList(
m))
6124 call deallocate_overlap_type(overlapList(
m))
6128 "mpp_domains_define.inc(set_contact_point):
pos should
equal to nrecv")
6131 call deallocate_overlap_type(overlap)
6133 end subroutine set_contact_point
6136 !--- done on current
pe for
east boundary for E-cell,
north boundary for N-cell,
6137 !--- East and North boundary for C-cell
6138 subroutine set_check_overlap( domain, position )
6139 type(domain2d), intent(in) :: domain
6140 integer, intent(in) :: position
6142 integer, parameter :: MAXCOUNT = 100
6144 integer :: nsend, nrecv,
pos, maxsize, rotation
6145 type(overlap_type) :: overlap
6146 type(overlapSpec), pointer :: update =>
NULL()
6149 select
case(position)
6151 update => domain%update_C
6152 check => domain%check_C
6154 update => domain%update_E
6155 check => domain%check_E
6157 update => domain%update_N
6158 check => domain%check_N
6160 call
mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
6163 check%xbegin = update%xbegin;
check%xend = update%xend
6164 check%ybegin = update%ybegin;
check%yend = update%yend
6167 if( .NOT. domain%symmetry ) return
6171 do
m = 1, update%nsend
6172 do
n = 1, update%
send(
m)%count
6173 if( update%
send(
m)%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6174 if( ( (position == EAST .OR. position == CORNER) .AND. update%
send(
m)%dir(
n) == 1 ) .OR. &
6175 ( (position == NORTH .OR. position == CORNER) .AND. update%
send(
m)%dir(
n) == 7 ) ) then
6176 maxsize =
max(maxsize, update%
send(
m)%count)
6185 call allocate_check_overlap(overlap, maxsize)
6189 nlist =
size(domain%list(:))
6190 !--- loop over the list of domains to find the boundary overlap for
send 6192 do
m = 1, update%nsend
6193 do
n = 1, update%
send(
m)%count
6194 if( update%
send(
m)%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6195 ! comparing
east direction on currently
pe 6196 if( (position == EAST .OR. position == CORNER) .AND. update%
send(
m)%dir(
n) == 1 ) then
6197 rotation = update%
send(
m)%rotation(
n)
6198 select
case( rotation )
6199 case( ZERO ) ! W -> E
6204 case( NINETY ) ! S -> E
6210 call insert_check_overlap(overlap, update%
send(
m)%
pe, &
6214 ! comparing
north direction on currently
pe 6215 if( (position == NORTH .OR. position == CORNER) .AND. update%
send(
m)%dir(
n) == 7 ) then
6216 rotation = update%
send(
m)%rotation(
n)
6217 select
case( rotation )
6223 case( MINUS_NINETY ) ! W->N
6229 call insert_check_overlap(overlap, update%
send(
m)%
pe, &
6233 if(overlap%count>0) then
6235 if(
pos>nsend)call
mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap):
pos is greater than nsend")
6237 call init_overlap_type(overlap)
6239 end do !
end do list = 0, nlist
6241 if(
pos .NE. nsend)call
mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap):
pos is greater than nsend")
6245 do
m = 1, update%nrecv
6246 do
n = 1, update%
recv(
m)%count
6247 if( update%
recv(
m)%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6248 if( ( (position == EAST .OR. position == CORNER) .AND. update%
recv(
m)%dir(
n) == 1 ) .OR. &
6249 ( (position == NORTH .OR. position == CORNER) .AND. update%
recv(
m)%dir(
n) == 7 ) ) then
6250 maxsize =
max(maxsize, update%
recv(
m)%count)
6257 if(nsend>0) call deallocate_overlap_type(overlap)
6261 call allocate_check_overlap(overlap, maxsize)
6265 do
m = 1, update%nrecv
6266 do
n = 1, update%
recv(
m)%count
6267 if( update%
recv(
m)%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6268 if( (position == EAST .OR. position == CORNER) .AND. update%
recv(
m)%dir(
n) == 1 ) then
6273 call insert_check_overlap(overlap, update%
recv(
m)%
pe, &
6276 if( (position == NORTH .OR. position == CORNER) .AND. update%
recv(
m)%dir(
n) == 7 ) then
6281 call insert_check_overlap(overlap, update%
recv(
m)%
pe, &
6284 end do !
n = 1, overlap%count
6285 if(overlap%count>0) then
6287 if(
pos>nrecv)call
mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap):
pos is greater than nrecv")
6289 call init_overlap_type(overlap)
6291 end do !
end do list = 0, nlist
6293 if(
pos .NE. nrecv)call
mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap):
pos is greater than nrecv")
6294 if(nrecv>0) call deallocate_overlap_type(overlap)
6296 end subroutine set_check_overlap
6298 !
############################################################################# 6299 !---
set up the overlapping
for boundary
if the domain
is symmetry.
6300 subroutine set_bound_overlap( domain, position )
6301 type(domain2d), intent(inout) :: domain
6302 integer, intent(in) :: position
6304 integer, parameter :: MAXCOUNT = 100
6308 type(overlap_type), pointer :: overlap =>
NULL()
6309 type(overlapSpec), pointer :: update =>
NULL()
6311 integer :: nlist_send, nlist_recv, ishift, jshift
6312 integer :: ism, iem, jsm, jem, nsend, nrecv
6314 !
integer :: isc1, iec1, jsc1, jec1
6315 !
integer :: isc2, iec2, jsc2, jec2
6319 integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
6320 integer :: is_south1, ie_south1, js_south1, je_south1
6321 integer :: is_south2, ie_south2, js_south2, je_south2
6322 integer :: is_west0, ie_west0, js_west0, je_west0
6323 integer :: is_west1, ie_west1, js_west1, je_west1
6324 integer :: is_west2, ie_west2, js_west2, je_west2
6325 logical :: x_cyclic, y_cyclic, folded_north
6327 is_south1=0; ie_south1=0; js_south1=0; je_south1=0
6328 is_south2=0; ie_south2=0; js_south2=0; je_south2=0
6329 is_west0=0; ie_west0=0; js_west0=0; je_west0=0
6330 is_west1=0; ie_west1=0; js_west1=0; je_west1=0
6331 is_west2=0; ie_west2=0; js_west2=0; je_west2=0
6334 if( position == CENTER .OR. .NOT. domain%symmetry )
return 6335 call mpp_get_domain_shift(domain, ishift, jshift, position)
6337 call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
6339 select
case(position)
6341 update => domain%update_C
6342 bound => domain%bound_C
6344 update => domain%update_E
6345 bound => domain%bound_E
6347 update => domain%update_N
6348 bound => domain%bound_N
6350 call
mpp_error( FATAL,
"mpp_domains_mod(set_bound_overlap): invalid option of position")
6353 bound%xbegin = ism;
bound%xend = iem + ishift
6354 bound%ybegin = jsm;
bound%yend = jem + jshift
6356 nlist_send =
max(update%nsend,4)
6357 nlist_recv =
max(update%nrecv,4)
6358 bound%nsend = nlist_send
6359 bound%nrecv = nlist_recv
6360 if(nlist_send >0) then
6364 if(nlist_recv >0) then
6368 !--- loop over the list of domains to find the boundary overlap for
send 6369 nlist =
size(domain%list(:))
6373 x_cyclic = domain%x(1)%
cyclic 6374 y_cyclic = domain%y(1)%
cyclic 6375 folded_north = BTEST(domain%fold,NORTH)
6376 ipos = domain%x(1)%
pos 6377 jpos = domain%y(1)%
pos 6382 if(domain%
ntiles == 1) then ! use neighbor processor to configure
send and
recv 6386 pe_south1 = NULL_PE; pe_south2 = NULL_PE
6387 if( position == NORTH .OR. position == CORNER ) then
6388 inbr = ipos; jnbr = jpos + 1
6389 if( jnbr ==
npes_y .AND. y_cyclic) jnbr = 0
6390 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6391 pe_south1 = domain%pearray(inbr,jnbr)
6392 is_south1 =
isc + ishift; ie_south1 =
iec+ishift
6393 js_south1 =
jec + jshift; je_south1 = js_south1
6396 !---
send to the southwest processor when position
is NORTH
6397 if( position == CORNER ) then
6398 inbr = ipos + 1; jnbr = jpos + 1
6399 if( inbr ==
npes_x .AND. x_cyclic) inbr = 0
6400 if( jnbr ==
npes_y .AND. y_cyclic) jnbr = 0
6401 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6402 pe_south2 = domain%pearray(inbr,jnbr)
6403 is_south2 =
iec + ishift; ie_south2 = is_south2
6404 js_south2 =
jec + jshift; je_south2 = js_south2
6409 pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6410 if( position == EAST ) then
6411 inbr = ipos+1; jnbr = jpos
6412 if( inbr ==
npes_x .AND. x_cyclic) inbr = 0
6413 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6414 pe_west1 = domain%pearray(inbr,jnbr)
6415 is_west1 =
iec + ishift; ie_west1 = is_west1
6416 js_west1 =
jsc + jshift; je_west1 =
jec + jshift
6418 else
if ( position == CORNER ) then ! possible split into
two parts.
6420 if( folded_north .AND.
jec ==
jeg .AND. ipos .LT. (
npes_x-1)/2 ) then
6421 inbr =
npes_x - ipos - 1; jnbr = jpos
6422 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6423 pe_west0 = domain%pearray(inbr,jnbr)
6424 is_west0 =
iec+ishift; ie_west0 = is_west0
6425 js_west0 =
jec+jshift; je_west0 = js_west0
6430 inbr = ipos+1; jnbr = jpos
6431 if( inbr ==
npes_x .AND. x_cyclic) inbr = 0
6432 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6433 pe_west1 = domain%pearray(inbr,jnbr)
6434 is_west1 =
iec + ishift; ie_west1 = is_west1
6435 js_west1 =
jsc + jshift; je_west1 =
jec 6438 inbr = ipos+1; jnbr = jpos
6439 if( inbr ==
npes_x .AND. x_cyclic) inbr = 0
6440 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6441 pe_west1 = domain%pearray(inbr,jnbr)
6442 is_west1 =
iec + ishift; ie_west1 = is_west1
6443 js_west1 =
jsc + jshift; je_west1 =
jec + jshift
6447 !---
send to the southwest processor when position
is NORTH
6448 if( position == CORNER ) then
6449 inbr = ipos + 1; jnbr = jpos + 1
6450 if( inbr ==
npes_x .AND. x_cyclic) inbr = 0
6451 if( jnbr ==
npes_y .AND. y_cyclic) jnbr = 0
6452 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6453 pe_west2 = domain%pearray(inbr,jnbr)
6454 is_west2 =
iec + ishift; ie_west2 = is_west2
6455 js_west2 =
jec + jshift; je_west2 = js_west2
6459 !write(1000+mpp_pe(),*)"
send south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
6460 !write(1000+mpp_pe(),*)"
send south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
6461 !write(1000+mpp_pe(),*)"
send west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
6462 !write(1000+mpp_pe(),*)"
send west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
6463 !write(1000+mpp_pe(),*)"
send west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
6467 m = mod( domain%
pos+list, nlist )
6469 my_pe = domain%list(
m)%
pe 6470 if(my_pe == pe_south1) then
6472 is(count) = is_south1;
ie(count) = ie_south1
6473 js(count) = js_south1;
je(count) = je_south1
6475 rotation(count) = ZERO
6477 if(my_pe == pe_south2) then
6479 is(count) = is_south2;
ie(count) = ie_south2
6480 js(count) = js_south2;
je(count) = je_south2
6482 rotation(count) = ZERO
6485 if(my_pe == pe_west0) then
6487 is(count) = is_west0;
ie(count) = ie_west0
6488 js(count) = js_west0;
je(count) = je_west0
6490 rotation(count) = ONE_HUNDRED_EIGHTY
6492 if(my_pe == pe_west1) then
6494 is(count) = is_west1;
ie(count) = ie_west1
6495 js(count) = js_west1;
je(count) = je_west1
6497 rotation(count) = ZERO
6499 if(my_pe == pe_west2) then
6501 is(count) = is_west2;
ie(count) = ie_west2
6502 js(count) = js_west2;
je(count) = je_west2
6504 rotation(count) = ZERO
6509 if(nsend > nlist_send) call
mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send")
6515 allocate(
bound%
send(nsend)%tileMe(count))
6522 bound%
send(nsend)%rotation(:) = rotation(1:count)
6523 !write(1000+mpp_pe(),*) "
send:", count, my_pe
6525 ! write(1000+mpp_pe(),*) "
send index:",
is(
i),
ie(
i),
js(
i),
je(
i), dir(
i), rotation(
i)
6530 !--- The following did
not consider wide halo
case.
6531 do
m = 1, update%nsend
6532 overlap => update%
send(
m)
6533 if( overlap%count == 0 ) cycle
6535 do
n = 1, overlap%count
6536 !--- currently
not support folded-
north 6537 if( overlap%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6538 if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(
n) == 1) then !
east 6541 rotation(count) = overlap%rotation(
n)
6542 tileMe(count) = overlap%tileMe(
n)
6543 select
case( rotation(count) )
6544 case( ZERO ) ! W -> E
6545 is(count) = overlap%
is(
n) - 1
6546 ie(count) =
is(count)
6547 js(count) = overlap%
js(
n)
6548 je(count) = overlap%
je(
n)
6549 case( NINETY ) ! S -> E
6550 is(count) = overlap%
is(
n)
6551 ie(count) = overlap%
ie(
n)
6552 js(count) = overlap%
js(
n) - 1
6553 je(count) =
js(count)
6556 if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(
n) == 3 ) then !
south 6559 rotation(count) = overlap%rotation(
n)
6560 tileMe(count) = overlap%tileMe(
n)
6561 select
case( rotation(count) )
6563 is(count) = overlap%
is(
n)
6564 ie(count) = overlap%
ie(
n)
6565 js(count) = overlap%
je(
n) + 1
6566 je(count) =
js(count)
6567 case( MINUS_NINETY ) ! E->S
6568 is(count) = overlap%
ie(
n) + 1
6569 ie(count) =
is(count)
6570 js(count) = overlap%
js(
n)
6571 je(count) = overlap%
je(
n)
6574 if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(
n) == 5 ) then !
west 6577 rotation(count) = overlap%rotation(
n)
6578 tileMe(count) = overlap%tileMe(
n)
6579 select
case( rotation(count) )
6581 is(count) = overlap%
ie(
n) + 1
6582 ie(count) =
is(count)
6583 js(count) = overlap%
js(
n)
6584 je(count) = overlap%
je(
n)
6585 case( NINETY ) ! N->W
6586 is(count) = overlap%
is(
n)
6587 ie(count) = overlap%
ie(
n)
6588 js(count) = overlap%
je(
n) + 1
6589 je(count) =
js(count)
6592 if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(
n) == 7 ) then !
north 6595 rotation(count) = overlap%rotation(
n)
6596 tileMe(count) = overlap%tileMe(
n)
6597 select
case( rotation(count) )
6599 is(count) = overlap%
is(
n)
6600 ie(count) = overlap%
ie(
n)
6601 js(count) = overlap%
js(
n) - 1
6602 je(count) =
js(count)
6603 case( MINUS_NINETY ) ! W->N
6604 is(count) = overlap%
is(
n) - 1
6605 ie(count) =
is(count)
6606 js(count) = overlap%
js(
n)
6607 je(count) = overlap%
je(
n)
6610 end do ! do
n =1, overlap%count
6618 allocate(
bound%
send(nsend)%tileMe(count))
6624 bound%
send(nsend)%tileMe(:) = tileMe(1:count)
6625 bound%
send(nsend)%rotation(:) = rotation(1:count)
6627 end do !
end do list = 0, nlist
6630 !--- loop over the list of domains to find the boundary overlap for
recv 6635 !---
will computing overlap for tripolar grid.
6640 pe_south1 = NULL_PE; pe_south2 = NULL_PE
6641 if( position == NORTH .OR. position == CORNER ) then
6642 inbr = ipos; jnbr = jpos - 1
6643 if( jnbr == -1 .AND. y_cyclic) jnbr =
npes_y-1
6644 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6645 pe_south1 = domain%pearray(inbr,jnbr)
6646 is_south1 =
isc + ishift; ie_south1 =
iec+ishift
6647 js_south1 =
jsc; je_south1 = js_south1
6651 !---
south boudary for
recv: the southwest point when position
is NORTH
6652 if( position == CORNER ) then
6653 inbr = ipos - 1; jnbr = jpos - 1
6654 if( inbr == -1 .AND. x_cyclic) inbr =
npes_x-1
6655 if( jnbr == -1 .AND. y_cyclic) jnbr =
npes_y-1
6656 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6657 pe_south2 = domain%pearray(inbr,jnbr)
6658 is_south2 =
isc; ie_south2 = is_south2
6659 js_south2 =
jsc; je_south2 = js_south2
6665 pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6666 if( position == EAST ) then
6667 inbr = ipos-1; jnbr = jpos
6668 if( inbr == -1 .AND. x_cyclic) inbr =
npes_x-1
6669 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6670 pe_west1 = domain%pearray(inbr,jnbr)
6671 is_west1 =
isc; ie_west1 = is_west1
6672 js_west1 =
jsc + jshift; je_west1 =
jec + jshift
6674 else
if ( position == CORNER ) then ! possible split into
two parts.
6676 if( folded_north .AND.
jec ==
jeg .AND. ipos .GT.
npes_x/2 ) then
6677 inbr =
npes_x - ipos - 1; jnbr = jpos
6678 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6679 pe_west0 = domain%pearray(inbr,jnbr)
6680 is_west0 =
isc; ie_west0 = is_west0
6681 js_west0 =
jec+jshift; je_west0 = js_west0
6683 inbr = ipos-1; jnbr = jpos
6684 if( inbr == -1 .AND. x_cyclic) inbr =
npes_x-1
6685 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6686 pe_west1 = domain%pearray(inbr,jnbr)
6687 is_west1 =
isc; ie_west1 = is_west1
6688 js_west1 =
jsc + jshift; je_west1 =
jec 6691 inbr = ipos-1; jnbr = jpos
6692 if( inbr == -1 .AND. x_cyclic) inbr =
npes_x-1
6693 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6694 pe_west1 = domain%pearray(inbr,jnbr)
6695 is_west1 =
isc; ie_west1 = is_west1
6696 js_west1 =
jsc + jshift; je_west1 =
jec+jshift
6701 !---
west boundary for
recv: the southwest point when position
is CORNER
6702 if( position == CORNER ) then
6703 inbr = ipos - 1; jnbr = jpos - 1
6704 if( inbr == -1 .AND. x_cyclic) inbr =
npes_x - 1
6705 if( jnbr == -1 .AND. y_cyclic) jnbr =
npes_y - 1
6706 if( inbr .GE. 0 .AND. inbr .LT.
npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT.
npes_y ) then
6707 pe_west2 = domain%pearray(inbr,jnbr)
6708 is_west2 =
isc; ie_west2 = is_west2
6709 js_west2 =
jsc; je_west2 = js_west2
6713 !write(1000+mpp_pe(),*)"
recv south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
6714 !write(1000+mpp_pe(),*)"
recv south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
6715 !write(1000+mpp_pe(),*)"
recv west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
6716 !write(1000+mpp_pe(),*)"
recv west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
6717 !write(1000+mpp_pe(),*)"
recv west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
6721 m = mod( domain%
pos+nlist-list, nlist )
6723 my_pe = domain%list(
m)%
pe 6724 if(my_pe == pe_south1) then
6726 is(count) = is_south1;
ie(count) = ie_south1
6727 js(count) = js_south1;
je(count) = je_south1
6729 rotation(count) = ZERO
6730 index(count) = 1 + ishift
6732 if(my_pe == pe_south2) then
6734 is(count) = is_south2;
ie(count) = ie_south2
6735 js(count) = js_south2;
je(count) = je_south2
6737 rotation(count) = ZERO
6740 if(my_pe == pe_west0) then
6742 is(count) = is_west0;
ie(count) = ie_west0
6743 js(count) = js_west0;
je(count) = je_west0
6745 rotation(count) = ONE_HUNDRED_EIGHTY
6746 index(count) =
jec-
jsc+1+jshift
6748 if(my_pe == pe_west1) then
6750 is(count) = is_west1;
ie(count) = ie_west1
6751 js(count) = js_west1;
je(count) = je_west1
6753 rotation(count) = ZERO
6754 index(count) = 1 + jshift
6756 if(my_pe == pe_west2) then
6758 is(count) = is_west2;
ie(count) = ie_west2
6759 js(count) = js_west2;
je(count) = je_west2
6761 rotation(count) = ZERO
6767 if(nrecv > nlist_recv) call
mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv")
6781 bound%
recv(nrecv)%rotation(:) = rotation(1:count)
6782 bound%
recv(nrecv)%index(:) = index(1:count)
6783 !write(1000+mpp_pe(),*) "
recv:", count, my_pe
6785 ! write(1000+mpp_pe(),*) "
recv index:",
is(
i),
ie(
i),
js(
i),
je(
i), dir(
i), rotation(
i)
6791 do
m = 1, update%nrecv
6792 overlap => update%
recv(
m)
6793 if( overlap%count == 0 ) cycle
6795 do
n = 1, overlap%count
6796 !--- currently
not support folded-
north 6797 if( overlap%rotation(
n) == ONE_HUNDRED_EIGHTY ) cycle
6798 if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(
n) == 1) then !
east 6801 rotation(count) = overlap%rotation(
n)
6802 tileMe(count) = overlap%tileMe(
n)
6803 is(count) = overlap%
is(
n) - 1
6804 ie(count) =
is(count)
6805 js(count) = overlap%
js(
n)
6806 je(count) = overlap%
je(
n)
6808 nrecvl(tMe, 1) = nrecvl(tMe,1) + 1
6809 isl (tMe,1,nrecvl(tMe, 1)) =
is (count)
6810 iel (tMe,1,nrecvl(tMe, 1)) =
ie (count)
6811 jsl (tMe,1,nrecvl(tMe, 1)) =
js (count)
6812 jel (tMe,1,nrecvl(tMe, 1)) =
je (count)
6815 if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(
n) == 3) then !
south 6818 rotation(count) = overlap%rotation(
n)
6819 tileMe(count) = overlap%tileMe(
n)
6820 is(count) = overlap%
is(
n)
6821 ie(count) = overlap%
ie(
n)
6822 js(count) = overlap%
je(
n) + 1
6823 je(count) =
js(count)
6825 nrecvl(tMe, 2) = nrecvl(tMe,2) + 1
6826 isl (tMe,2,nrecvl(tMe, 2)) =
is (count)
6827 iel (tMe,2,nrecvl(tMe, 2)) =
ie (count)
6828 jsl (tMe,2,nrecvl(tMe, 2)) =
js (count)
6829 jel (tMe,2,nrecvl(tMe, 2)) =
je (count)
6832 if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(
n) == 5) then !
west 6835 rotation(count) = overlap%rotation(
n)
6836 tileMe(count) = overlap%tileMe(
n)
6837 is(count) = overlap%
ie(
n) + 1
6838 ie(count) =
is(count)
6839 js(count) = overlap%
js(
n)
6840 je(count) = overlap%
je(
n)
6842 nrecvl(tMe, 3) = nrecvl(tMe,3) + 1
6843 isl (tMe,3,nrecvl(tMe, 3)) =
is (count)
6844 iel (tMe,3,nrecvl(tMe, 3)) =
ie (count)
6845 jsl (tMe,3,nrecvl(tMe, 3)) =
js (count)
6846 jel (tMe,3,nrecvl(tMe, 3)) =
je (count)
6849 if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(
n) == 7) then !
north 6852 rotation(count) = overlap%rotation(
n)
6853 tileMe(count) = overlap%tileMe(
n)
6854 is(count) = overlap%
is(
n)
6855 ie(count) = overlap%
ie(
n)
6856 js(count) = overlap%
js(
n) - 1
6857 je(count) =
js(count)
6859 nrecvl(tMe, 4) = nrecvl(tMe,4) + 1
6860 isl (tMe,4,nrecvl(tMe, 4)) =
is (count)
6861 iel (tMe,4,nrecvl(tMe, 4)) =
ie (count)
6862 jsl (tMe,4,nrecvl(tMe, 4)) =
js (count)
6863 jel (tMe,4,nrecvl(tMe, 4)) =
je (count)
6865 end do ! do
n = 1, overlap%count
6879 bound%
recv(nrecv)%tileMe(:) = tileMe(1:count)
6880 bound%
recv(nrecv)%rotation(:) = rotation(1:count)
6882 end do !
end do list = 0, nlist
6883 !--- find the boundary index for each contact within the
east boundary
6889 do l = 1, nrecvl(tMe,dr)
6890 if(dr == 1 .OR. dr == 3) then ! EAST, WEST
6894 max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l))+1, &
6895 abs(iel(tMe, dr, l)-isl(tMe, dr, l))+1)
6898 max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6899 abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - jshift
6905 max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6906 abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - ishift
6917 end subroutine set_bound_overlap
6920 !
############################################################################# 6922 subroutine fill_corner_contact(eCont, sCont, wCont, nCont,
isg,
ieg,
jsg,
jeg, numR, numS, tileRecv, tileSend, &
6923 is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv, &
6924 is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send, &
6925 align1Recv, align2Recv, align1Send, align2Send, &
6926 whalo, ehalo, shalo, nhalo, tileMe)
6927 type(contact_type),
dimension(:), intent(in) :: eCont, sCont, wCont, nCont
6929 integer, intent(inout) :: numR, numS
6935 integer,
dimension(:), intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
6936 integer, intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
6937 integer :: is1, ie1, js1, je1, is2, ie2, js2, je2
6939 logical :: found_corner
6941 found_corner = .
false.
6942 !--- southeast for recving
6943 if(eCont(tileMe)%ncontact > 0) then
6944 if(eCont(tileMe)%js1(1) ==
jsg(tileMe) ) then
6945 tn = eCont(tileMe)%
tile(1)
6947 if( econt(tileMe)%js2(1) -
jsg(tn) < shalo ) call
mpp_error(FATAL, &
6948 "mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
6949 found_corner = .
true.;
tc = tn
6950 is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6951 is2 = eCont(tileMe)%is2(1); je2 = eCont(tileMe)%js2(1) - 1
6953 if(sCont(tn)%is1(1) ==
isg(tn)) then !
corner is nc.
6954 found_corner = .true.;
tc = sCont(tn)%
tile(1)
6955 is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6956 is2 = sCont(tn)%is2(1); je2 = sCont(tn)%je2(1)
6961 if( .
not. found_corner ) then !
not found,
6962 n = sCont(tileMe)%ncontact
6964 if( sCont(tileMe)%ie1(
n) ==
ieg(tileMe)) then
6965 tn = sCont(tileMe)%
tile(
n)
6968 "mpp_domains_define.inc: southeast
tile for
recv 2
is not tiled properly")
6969 found_corner = .
true.;
tc = tn
6970 is1 = sCont(tileMe)%ie1(
n) + 1; je1 = sCont(tileMe)%js1(
n) - 1
6971 is2 = sCont(tileMe)%ie2(
n) + 1; je2 = sCont(tileMe)%je2(
n)
6973 m = eCont(tn)%ncontact
6976 is1 = sCont(tileMe)%ie1(
n) + 1; je1 = sCont(tileMe)%js1(
n) - 1
6977 is2 = eCont(tn)%is2(
m); je2 = eCont(tn)%je2(
m)
6983 if(found_corner) then
6985 tileRecv(numR) =
tc; align1Recv(numR) = SOUTH_EAST; align2Recv(numR) = NORTH_WEST
6986 is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
6987 js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
6988 is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
6989 js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
6992 !--- southwest for recving
6993 found_corner = .
false.
6994 if(wCont(tileMe)%ncontact > 0) then
6995 if(wCont(tileMe)%js1(1) ==
jsg(tileMe) ) then
6996 tn = wCont(tileMe)%
tile(1)
6998 if( wcont(tileMe)%js2(1) -
jsg(tn) < shalo ) call
mpp_error(FATAL, &
6999 "mpp_domains_define.inc: southwest
tile for
recv 1
is not tiled properly")
7000 found_corner = .
true.;
tc = tn
7001 ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7002 ie2 = wCont(tileMe)%is2(1); je2 = wCont(tileMe)%js2(1) - 1
7004 n = sCont(tn)%ncontact
7007 ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7008 ie2 = sCont(tn)%ie2(1); je2 = sCont(tn)%je2(1)
7013 if( .
not. found_corner ) then !
not found,
7014 n = sCont(tileMe)%ncontact
7016 if( sCont(tileMe)%is1(1) ==
isg(tileMe)) then
7017 tn = sCont(tileMe)%
tile(1)
7019 if( scont(tileMe)%is2(1)-
isg(tn) < whalo ) call
mpp_error(FATAL, &
7020 "mpp_domains_define.inc: southwest
tile for
recv 1
is not tiled properly")
7021 found_corner = .
true.;
tc = tn
7022 ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7023 ie2 = sCont(tileMe)%is2(1) - 1; je2 = sCont(tileMe)%js2(1)
7025 m = wCont(tn)%ncontact
7028 ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7029 ie2 = wCont(tn)%ie2(
m); je2 = wCont(tn)%je2(
m)
7035 if(found_corner) then
7037 tileRecv(numR) =
tc; align1Recv(numR) = SOUTH_WEST; align2Recv(numR) = NORTH_EAST
7038 is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7039 js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
7040 is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7041 js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
7044 !--- northwest for recving
7045 found_corner = .
false.
7046 n = wCont(tileMe)%ncontact
7048 if(wCont(tileMe)%je1(
n) ==
jeg(tileMe) ) then
7049 tn = wCont(tileMe)%
tile(
n)
7052 "mpp_domains_define.inc: northwest
tile for
recv 1
is not tiled properly")
7053 found_corner = .
true.;
tc = tn
7054 ie1 = wCont(tileMe)%is1(
n) - 1; js1 = wCont(tileMe)%je1(
n) + 1
7055 ie2 = wCont(tileMe)%is2(
n); js2 = wCont(tileMe)%je2(
n) + 1
7057 m = nCont(tn)%ncontact
7060 ie1 = wCont(tileMe)%is1(
n) - 1; js1 = wCont(tileMe)%je1(
n) + 1
7061 ie2 = nCont(tn)%ie2(
m); js2 = nCont(tn)%js2(
m)
7066 if( .
not. found_corner ) then !
not found,
7067 if( nCont(tileMe)%ncontact > 0) then
7068 if( nCont(tileMe)%is1(1) ==
isg(tileMe)) then
7069 tn = nCont(tileMe)%
tile(1)
7071 if( ncont(tileMe)%is2(1)-
isg(tn) < whalo ) call
mpp_error(FATAL, &
7072 "mpp_domains_define.inc: northwest
tile for
recv 2
is not tiled properly")
7073 found_corner = .
true.;
tc = tn
7074 ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7075 ie2 = nCont(tileMe)%is2(1) - 1; js2 = nCont(tileMe)%js2(1)
7078 found_corner = .
true.;
tc = wCont(tn)%
tile(1)
7079 ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7080 ie2 = wCont(tn)%ie2(1); js2 = wCont(tn)%js2(1)
7086 if(found_corner) then
7088 tileRecv(numR) =
tc; align1Recv(numR) =NORTH_WEST; align2Recv(numR) = SOUTH_EAST
7089 is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7090 js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
7091 is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7092 js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
7095 !--- northeast for recving
7096 found_corner = .
false.
7097 n = eCont(tileMe)%ncontact
7099 if(eCont(tileMe)%je1(
n) ==
jeg(tileMe) ) then
7100 tn = eCont(tileMe)%
tile(
n)
7103 "mpp_domains_define.inc: northeast
tile for
recv 1
is not tiled properly")
7104 found_corner = .
true.;
tc = tn
7105 is1 = eCont(tileMe)%ie1(
n) + 1; js1 = eCont(tileMe)%je1(
n) + 1
7106 is2 = eCont(tileMe)%is2(1); js2 = eCont(tileMe)%je2(1) + 1
7109 found_corner = .
true.;
tc = nCont(tn)%
tile(1)
7110 is1 = eCont(tileMe)%ie1(
n) + 1; js1 = eCont(tileMe)%je1(
n) + 1
7111 is2 = nCont(tn)%is2(1); js2 = nCont(tn)%js2(1)
7116 if( .
not. found_corner ) then !
not found,
7117 n = nCont(tileMe)%ncontact
7119 if( nCont(tileMe)%ie1(
n) ==
ieg(tileMe)) then
7120 tn = nCont(tileMe)%
tile(
n)
7123 "mpp_domains_define.inc: northeast
tile for
recv 2
is not tiled properly")
7124 found_corner = .
true.;
tc = tn
7125 is1 = sCont(tileMe)%ie1(
n) + 1; js1 = sCont(tileMe)%je1(
n) + 1
7126 is2 = sCont(tileMe)%ie2(
n) + 1; js2 = sCont(tileMe)%js2(
n)
7129 found_corner = .
true.;
tc = eCont(tn)%
tile(1)
7130 is1 = sCont(tileMe)%ie1(
n) + 1; js1 = sCont(tileMe)%je1(
n) + 1
7131 is2 = eCont(tn)%is2(
m); js2 = eCont(tn)%js2(
m)
7137 if(found_corner) then
7139 tileRecv(numR) =
tc; align1Recv(numR) =NORTH_EAST; align2Recv(numR) = SOUTH_WEST
7140 is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
7141 js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
7142 is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
7143 js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
7147 do
n = 1, wCont(tileMe)%ncontact
7148 tn = wCont(tileMe)%
tile(
n)
7149 if(wCont(tileMe)%js2(
n) ==
jsg(tn) ) then
7151 if( wcont(tileMe)%js1(
n) -
jsg(tileMe) < shalo ) call
mpp_error(FATAL, &
7152 "mpp_domains_define.inc: southeast
tile for
send 1
is not tiled properly")
7153 numS = numS+1; tileSend(numS) = tn
7154 align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7155 is1Send(numS) = wCont(tileMe)%is1(
n); ie1Send(numS) = is1Send(numS) + ehalo - 1
7156 je1Send(numS) = wCont(tileMe)%js1(
n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7157 is2Send(numS) = wCont(tileMe)%ie2(
n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7158 je2Send(numS) = wCont(tileMe)%js2(
n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7162 do
n = 1, nCont(tileMe)%ncontact
7163 tn = nCont(tileMe)%
tile(
n)
7164 if(nCont(tileMe)%ie2(
n) ==
ieg(tn) ) then
7166 if(
ieg(tileMe) - nCont(tileMe)%ie1(
n) < ehalo ) call
mpp_error(FATAL, &
7167 "mpp_domains_define.inc: southeast
tile for
send 2
is not tiled properly")
7168 numS = numS+1; tileSend(numS) = tn
7169 align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7170 is1Send(numS) = nCont(tileMe)%ie1(
n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7171 je1Send(numS) = nCont(tileMe)%je1(
n) ; js1Send(numS) = je1Send(numS) - shalo + 1
7172 is2Send(numS) = nCont(tileMe)%ie2(
n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7173 je2Send(numS) = nCont(tileMe)%je2(
n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7178 !--- found the
corner overlap that
is not specified through contact line.
7179 n = wCont(tileMe)%ncontact
7180 found_corner = .
false.
7182 tn = wCont(tileMe)%
tile(
n)
7183 if( wCont(tileMe)%je1(
n) ==
jeg(tileMe) .AND. wCont(tileMe)%je2(
n) ==
jeg(tn) ) then
7184 m = nCont(tn)%ncontact
7187 if( nCont(tn)%ie1(
m) ==
ieg(tn) .AND. nCont(tn)%ie2(
m) ==
ieg(
tc) ) found_corner = .
true.
7191 if( .
not. found_corner ) then !
not found, then starting from
north contact
7192 if( nCont(tileMe)%ncontact > 0) then
7193 tn = nCont(tileMe)%
tile(1)
7194 if( nCont(tileMe)%is1(1) ==
isg(tileMe) .AND. nCont(tileMe)%is2(1) ==
isg(tn) ) then
7195 if(wCont(tn)%ncontact >0) then
7197 if( wCont(tn)%js1(1) ==
jsg(tn) .AND. wCont(tn)%js2(1) ==
jsg(
tc) ) found_corner = .
true.
7203 if(found_corner) then
7204 numS = numS+1; tileSend(numS) =
tc 7205 align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7206 is1Send(numS) =
isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7207 je1Send(numS) =
jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7208 is2Send(numS) =
ieg(
tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7209 je2Send(numS) =
jsg(
tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7213 do
n = 1, eCont(tileMe)%ncontact
7214 tn = eCont(tileMe)%
tile(
n)
7215 if(eCont(tileMe)%js2(
n) ==
jsg(tn) ) then
7217 if( econt(tileMe)%js1(
n) -
jsg(tileMe) < shalo ) call
mpp_error(FATAL, &
7218 "mpp_domains_define.inc: southwest
tile for
send 1
is not tiled properly")
7219 numS = numS+1; tileSend(numS) = tn
7220 align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7221 ie1Send(numS) = eCont(tileMe)%ie1(
n); is1Send(numS) = ie1Send(numS) - whalo + 1
7222 je1Send(numS) = eCont(tileMe)%js1(
n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7223 ie2Send(numS) = eCont(tileMe)%is2(
n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7224 je2Send(numS) = eCont(tileMe)%js2(
n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7228 do
n = 1, nCont(tileMe)%ncontact
7229 tn = nCont(tileMe)%
tile(
n)
7230 if(nCont(tileMe)%is2(
n) ==
isg(tn) ) then
7232 if( ncont(tileMe)%is1(
n) -
isg(tileMe) < whalo ) call
mpp_error(FATAL, &
7233 "mpp_domains_define.inc: southwest
tile for
send 2
is not tiled properly")
7234 numS = numS+1; tileSend(numS) = tn
7235 align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7236 ie1Send(numS) = nCont(tileMe)%is1(
n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7237 ie1Send(numS) = nCont(tileMe)%je1(
n) ; js1Send(numS) = je1Send(numS) - shalo + 1
7238 ie2Send(numS) = nCont(tileMe)%is2(
n) - 1; is2Send(numS) = je2Send(numS) - whalo + 1
7239 je2Send(numS) = nCont(tileMe)%js2(
n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7244 !--- found the
corner overlap that
is not specified through contact line.
7245 n = eCont(tileMe)%ncontact
7246 found_corner = .
false.
7248 tn = eCont(tileMe)%
tile(
n)
7249 if( eCont(tileMe)%je1(
n) ==
jeg(tileMe) .AND. eCont(tileMe)%je2(
n) ==
jeg(tn) ) then
7250 if(nCont(tn)%ncontact >0) then
7252 if( nCont(tn)%is1(1) ==
isg(tn) .AND. nCont(tn)%is2(
n) ==
isg(
tc) ) found_corner = .
true.
7256 if( .
not. found_corner ) then !
not found, then starting from
north contact
7257 n = nCont(tileMe)%ncontact
7259 tn = nCont(tileMe)%
tile(
n)
7260 if( nCont(tileMe)%ie1(
n) ==
ieg(tileMe) .AND. nCont(tileMe)%ie2(
n) ==
ieg(tn) ) then
7261 if(eCont(tn)%ncontact >0) then
7263 if( eCont(tn)%js1(1) ==
jsg(tn) .AND. eCont(tn)%js2(
n) ==
jsg(
tc) ) found_corner = .
true.
7269 if(found_corner) then
7270 numS = numS+1; tileSend(numS) =
tc 7271 align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7272 ie1Send(numS) =
ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7273 je1Send(numS) =
jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7274 ie2Send(numS) =
isg(
tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7275 je2Send(numS) =
jsg(
tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7279 do
n = 1, eCont(tileMe)%ncontact
7280 tn = eCont(tileMe)%
tile(
n)
7281 if(eCont(tileMe)%je2(
n) ==
jeg(tn) ) then
7283 if(
jeg(tileMe) - econt(tileMe)%je1(
n) < nhalo ) call
mpp_error(FATAL, &
7284 "mpp_domains_define.inc: northwest
tile for
send 1
is not tiled properly")
7285 numS = numS+1; tileSend(numS) = tn
7286 align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7287 ie1Send(numS) = eCont(tileMe)%ie1(
n) ; is1Send(numS) = ie1Send(numS) - whalo + 1
7288 js1Send(numS) = eCont(tileMe)%je1(
n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7289 ie2Send(numS) = eCont(tileMe)%is2(
n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7290 js2Send(numS) = eCont(tileMe)%je2(
n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7295 do
n = 1, sCont(tileMe)%ncontact
7296 tn = sCont(tileMe)%
tile(
n)
7297 if(sCont(tileMe)%is2(
n) ==
isg(tn) ) then
7299 if( scont(tileMe)%is1(
n) -
isg(tileMe) < whalo ) call
mpp_error(FATAL, &
7300 "mpp_domains_define.inc: southwest
tile for
send 2
is not tiled properly")
7301 numS = numS+1; tileSend(numS) = tn
7302 align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7303 ie1Send(numS) = nCont(tileMe)%is1(
n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7304 js1Send(numS) = nCont(tileMe)%je1(
n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
7305 ie2Send(numS) = nCont(tileMe)%is2(
n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7306 js2Send(numS) = nCont(tileMe)%je2(
n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7311 !--- found the
corner overlap that
is not specified through contact line.
7312 n = eCont(tileMe)%ncontact
7313 found_corner = .
false.
7315 tn = eCont(tileMe)%
tile(1)
7316 if( eCont(tileMe)%js1(1) ==
jsg(tileMe) .AND. eCont(tileMe)%js2(1) ==
jsg(tn) ) then
7317 if(sCont(tn)%ncontact >0) then
7319 if( sCont(tn)%is1(1) ==
isg(tn) .AND. sCont(tn)%is2(1) ==
isg(
tc) ) found_corner = .
true.
7323 if( .
not. found_corner ) then !
not found, then starting from
north contact
7324 n = sCont(tileMe)%ncontact
7325 found_corner = .
false.
7327 tn = sCont(tileMe)%
tile(
n)
7328 if( sCont(tileMe)%ie1(
n) ==
ieg(tileMe) .AND. sCont(tileMe)%ie2(
n) ==
ieg(tn) ) then
7329 if(eCont(tn)%ncontact >0) then
7331 if( eCont(tn)%je1(
n) ==
jeg(tn) .AND. eCont(tn)%je2(
n) ==
jeg(
tc) ) found_corner = .
true.
7337 if(found_corner) then
7338 numS = numS+1; tileSend(numS) =
tc 7339 align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7340 ie1Send(numS) =
ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7341 js1Send(numS) =
jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7342 ie2Send(numS) =
isg(
tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7343 js2Send(numS) =
jeg(
tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7347 do
n = 1, wCont(tileMe)%ncontact
7348 tn = wCont(tileMe)%
tile(
n)
7349 if(wCont(tileMe)%je2(
n) ==
jeg(tn) ) then
7351 if(
jeg(tileMe) - wcont(tileMe)%je1(
n) < nhalo ) call
mpp_error(FATAL, &
7352 "mpp_domains_define.inc: northeast
tile for
send 1
is not tiled properly")
7353 numS = numS+1; tileSend(numS) = tn
7354 align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7355 is1Send(numS) = wCont(tileMe)%is1(
n) ; ie1Send(numS) = is1Send(numS) + ehalo - 1
7356 js1Send(numS) = wCont(tileMe)%je1(
n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7357 is2Send(numS) = wCont(tileMe)%ie2(
n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7358 js2Send(numS) = wCont(tileMe)%je2(
n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7363 do
n = 1, sCont(tileMe)%ncontact
7364 tn = sCont(tileMe)%
tile(
n)
7365 if(sCont(tileMe)%ie2(
n) ==
ieg(tn) ) then
7367 if(
ieg(tileMe) - sCont(tileMe)%ie1(
n) < ehalo ) call
mpp_error(FATAL, &
7368 "mpp_domains_define.inc: southeast
tile for
send 2
is not tiled properly")
7369 numS = numS+1; tileSend(numS) = tn
7370 align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7371 is1Send(numS) = sCont(tileMe)%ie1(
n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7372 js1Send(numS) = sCont(tileMe)%js1(
n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
7373 is2Send(numS) = sCont(tileMe)%ie2(
n) + 1; ie2Send(numS) = is1Send(numS) + ehalo - 1
7374 js2Send(numS) = sCont(tileMe)%je2(
n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7379 !--- found the
corner overlap that
is not specified through contact line.
7380 n = wCont(tileMe)%ncontact
7381 found_corner = .
false.
7383 tn = wCont(tileMe)%
tile(1)
7384 if( wCont(tileMe)%js1(
n) ==
jsg(tileMe) .AND. wCont(tileMe)%js2(
n) ==
jsg(tn) ) then
7385 m = sCont(tn)%ncontact
7388 if( sCont(tn)%ie1(
m) ==
ieg(tn) .AND. sCont(tn)%ie2(
m) ==
ieg(
tc) ) found_corner = .
true.
7392 if( .
not. found_corner ) then !
not found, then starting from
north contact
7393 n = sCont(tileMe)%ncontact
7394 found_corner = .
false.
7396 tn = sCont(tileMe)%
tile(1)
7397 if( sCont(tileMe)%is1(1) ==
isg(tileMe) .AND. sCont(tileMe)%is2(1) ==
isg(tn) ) then
7398 m = wCont(tn)%ncontact
7401 if( wCont(tn)%je1(
m) ==
jeg(tn) .AND. wCont(tn)%je2(
m) ==
jeg(
tc) ) found_corner = .
true.
7406 if(found_corner) then
7407 numS = numS+1; tileSend(numS) =
tc 7408 align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7409 is1Send(numS) =
isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7410 js1Send(numS) =
jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7411 is2Send(numS) =
ieg(
tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7412 js2Send(numS) =
jeg(
tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7415 end subroutine fill_corner_contact
7417 !--- find the alignment direction,
check if index
is reversed,
if reversed, exchange index.
7424 if (
is ==
ie ) then ! x-alignment
7430 call
mpp_error(FATAL, 'mpp_domains_define.inc: The contact region
is not on the x-boundary of the
tile')
7435 else
if (
js ==
je ) then ! y-alignment
7441 call
mpp_error(FATAL, 'mpp_domains_define.inc: The contact region
is not on the y-boundary of the
tile')
7447 call
mpp_error(FATAL, 'mpp_domains_define.inc: The contact region should be line contact' )
7450 end subroutine check_alignment
7451 !
##################################################################### 7453 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7455 ! MPP_MODIFY_DOMAIN: modify extent of domain !
7457 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7458 ! <SUBROUTINE NAME=
"mpp_modify_domain1D" INTERFACE=
"mpp_modify_domain">
7459 ! <IN NAME=
"domain_in" TYPE=
"type(domain1D)" > </IN>
7460 ! <IN NAME=
"hbegin,hend" TYPE=
"integer,optional" > </IN>
7461 ! <IN NAME=
"cbegin,cend" TYPE=
"integer,optional" > </IN>
7462 ! <IN NAME=
"gbegin,gend" TYPE=
"integer,optional" > </IN>
7463 ! <INOUT NAME=
"domain_out" TYPE=
"type(domain1D)" > </INOUT>
7466 subroutine mpp_modify_domain1D(
domain_in,
domain_out,cbegin,cend,gbegin,gend, hbegin, hend)
7470 integer, intent(in), optional :: hbegin, hend ! halo
size 7471 integer, intent(in), optional :: cbegin, cend ! extent of compute_domain
7472 integer, intent(in), optional :: gbegin, gend ! extent of
global domain
7475 ! get the
global indices of the input domain
7484 if(
domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN
7487 flags = flag, begin_halo = hbegin, end_halo = hend, extent =
domain_in%list(:)%compute%
size )
7496 end subroutine mpp_modify_domain1D
7499 !#######################################################################
7500 !----------------------------------------------------------------------------------
7501 ! <SUBROUTINE NAME=
"mpp_modify_domain2D" INTERFACE=
"mpp_modify_domain">
7502 ! <IN NAME=
"domain_in" TYPE=
"type(domain2D)" > </IN>
7503 ! <IN NAME=
"isc,iec" TYPE=
"integer,optional" > </IN>
7504 ! <IN NAME=
"jsc,jec" TYPE=
"integer,optional" > </IN>
7505 ! <IN NAME=
"isg,ieg" TYPE=
"integer,optional" > </IN>
7506 ! <IN NAME=
"jsg,jeg" TYPE=
"integer,optional" > </IN>
7507 ! <IN NAME=
"whalo,ehalo" TYPE=
"integer,optional" > </IN>
7508 ! <IN NAME=
"shalo,nhalo" TYPE=
"integer,optional" > </IN>
7509 ! <INOUT NAME=
"domain_out" TYPE=
"type(domain2D)" > </INOUT>
7512 subroutine mpp_modify_domain2D(
domain_in,
domain_out,
isc,
iec,
jsc,
jec,
isg,
ieg,
jsg,
jeg, whalo, ehalo, shalo, nhalo)
7518 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
7522 if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) then
7523 ! get the
global indices of the input domain
7531 xflag = 0; yflag = 0
7533 if(
domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN
7535 if(
domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN
7538 xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, &
7539 shalo = shalo, nhalo = nhalo, &
7543 maskmap =
domain_in%pearray .NE. NULL_PE )
7560 end subroutine mpp_modify_domain2D
7563 !
##################################################################### 7566 subroutine mpp_define_null_domain1D(domain)
7567 type(domain1D), intent(inout) :: domain
7570 domain%data%
begin = -1; domain%data%
end = -1; domain%data%
size = 0
7571 domain%compute%
begin = -1; domain%compute%
end = -1; domain%compute%
size = 0
7574 end subroutine mpp_define_null_domain1D
7576 !#####################################################################
7579 subroutine mpp_define_null_domain2D(domain)
7580 type(domain2D), intent(inout) :: domain
7582 allocate(domain%x(1), domain%y(1), domain%tile_id(1))
7583 call mpp_define_null_domain(domain%x(1))
7584 call mpp_define_null_domain(domain%y(1))
7586 domain%tile_id(1) = 1
7588 domain%max_ntile_pe = 1
7589 domain%ncontacts = 0
7591 end subroutine mpp_define_null_domain2D
7593 !####################################################################
7595 subroutine mpp_deallocate_domain1D(domain)
7596 type(domain1D), intent(inout) :: domain
7598 if(ASSOCIATED(domain%list)) deallocate(domain%list)
7600 end subroutine mpp_deallocate_domain1D
7602 !####################################################################
7604 subroutine mpp_deallocate_domain2D(domain)
7605 type(domain2D), intent(inout) :: domain
7607 call deallocate_domain2D_local(domain)
7608 if(ASSOCIATED(domain%io_domain) ) then
7609 call deallocate_domain2D_local(domain%io_domain)
7610 deallocate(domain%io_domain)
7613 end subroutine mpp_deallocate_domain2D
7615 !##################################################################
7617 subroutine deallocate_domain2D_local(domain)
7618 type(domain2D), intent(inout) :: domain
7621 ntileMe =
size(domain%x(:))
7623 if(ASSOCIATED(domain%pearray))deallocate(domain%pearray)
7625 call mpp_deallocate_domain1D(domain%x(
i))
7626 call mpp_deallocate_domain1D(domain%y(
i))
7628 deallocate(domain%x, domain%y, domain%tile_id)
7630 if(ASSOCIATED(domain%list)) then
7631 do
i = 0,
size(domain%list(:))-1
7632 deallocate(domain%list(
i)%x, domain%list(
i)%y, domain%list(
i)%tile_id)
7634 deallocate(domain%list)
7637 if(ASSOCIATED(domain%check_C)) call deallocate_overlapSpec(domain%check_C)
7638 if(ASSOCIATED(domain%check_E)) call deallocate_overlapSpec(domain%check_E)
7639 if(ASSOCIATED(domain%check_N)) call deallocate_overlapSpec(domain%check_N)
7640 if(ASSOCIATED(domain%bound_C)) call deallocate_overlapSpec(domain%bound_C)
7641 if(ASSOCIATED(domain%bound_E)) call deallocate_overlapSpec(domain%bound_E)
7642 if(ASSOCIATED(domain%bound_N)) call deallocate_overlapSpec(domain%bound_N)
7643 if(ASSOCIATED(domain%update_T)) call deallocate_overlapSpec(domain%update_T)
7644 if(ASSOCIATED(domain%update_E)) call deallocate_overlapSpec(domain%update_E)
7645 if(ASSOCIATED(domain%update_C)) call deallocate_overlapSpec(domain%update_C)
7646 if(ASSOCIATED(domain%update_N)) call deallocate_overlapSpec(domain%update_N)
7648 end subroutine deallocate_domain2D_local
7650 !####################################################################
7652 subroutine allocate_check_overlap(overlap, count)
7653 type(overlap_type), intent(inout) :: overlap
7657 overlap%
pe = NULL_PE
7658 if(associated(overlap%tileMe)) call
mpp_error(FATAL, &
7659 "allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
7661 "allocate_check_overlap(mpp_domains_define): count should be a positive integer")
7662 allocate(overlap%tileMe (count), overlap%dir(count) )
7663 allocate(overlap%
is (count), overlap%
ie (count) )
7664 allocate(overlap%
js (count), overlap%
je (count) )
7665 allocate(overlap%rotation(count) )
7666 overlap%rotation = ZERO
7668 end subroutine allocate_check_overlap
7670 !#######################################################################
7671 subroutine insert_check_overlap(overlap,
pe, tileMe, dir, rotation,
is,
ie,
js,
je)
7672 type(overlap_type), intent(inout) :: overlap
7674 integer, intent(in ) :: tileMe, dir, rotation
7678 overlap%count = overlap%count + 1
7679 count = overlap%count
7680 if(.NOT. associated(overlap%tileMe)) call
mpp_error(FATAL, &
7681 "mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
7683 "mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
7684 if( overlap%
pe == NULL_PE ) then
7688 "mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
7690 overlap%tileMe (count) = tileMe
7691 overlap%dir (count) = dir
7692 overlap%rotation(count) = rotation
7693 overlap%
is (count) =
is 7694 overlap%
ie (count) =
ie 7695 overlap%
js (count) =
js 7696 overlap%
je (count) =
je 7698 end subroutine insert_check_overlap
7700 !#######################################################################
7701 !--- this routine
add the overlap_in into overlap_out
7702 subroutine add_check_overlap( overlap_out, overlap_in)
7703 type(overlap_type), intent(inout) :: overlap_out
7704 type(overlap_type), intent(in ) :: overlap_in
7705 type(overlap_type) :: overlap
7706 integer :: count, count_in, count_out
7708 !
if overlap_out%count == 0, then just
copy overlap_in to overlap_out
7709 count_in = overlap_in %count
7710 count_out = overlap_out%count
7711 count = count_in+count_out
7713 "add_check_overlap(mpp_domains_define): overlap_in%count is zero")
7715 if(count_out == 0) then
7716 if(associated(overlap_out%tileMe)) call
mpp_error(FATAL, &
7717 "add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
7718 call allocate_check_overlap(overlap_out, count_in)
7719 overlap_out%
pe = overlap_in%
pe 7721 call allocate_check_overlap(overlap, count_out)
7723 "mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
7724 overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7725 overlap%
is (1:count_out) = overlap_out%
is (1:count_out)
7726 overlap%
ie (1:count_out) = overlap_out%
ie (1:count_out)
7727 overlap%
js (1:count_out) = overlap_out%
js (1:count_out)
7728 overlap%
je (1:count_out) = overlap_out%
je (1:count_out)
7729 overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7730 overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7731 call deallocate_overlap_type(overlap_out)
7732 call allocate_check_overlap(overlap_out, count)
7733 overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7734 overlap_out%
is (1:count_out) = overlap%
is (1:count_out)
7735 overlap_out%
ie (1:count_out) = overlap%
ie (1:count_out)
7736 overlap_out%
js (1:count_out) = overlap%
js (1:count_out)
7737 overlap_out%
je (1:count_out) = overlap%
je (1:count_out)
7738 overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7739 overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7740 call deallocate_overlap_type(overlap)
7742 overlap_out%count = count
7743 overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7744 overlap_out%
is (count_out+1:count) = overlap_in%
is (1:count_in)
7745 overlap_out%
ie (count_out+1:count) = overlap_in%
ie (1:count_in)
7746 overlap_out%
js (count_out+1:count) = overlap_in%
js (1:count_in)
7747 overlap_out%
je (count_out+1:count) = overlap_in%
je (1:count_in)
7748 overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7749 overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7751 end subroutine add_check_overlap
7753 !####################################################################
7754 subroutine init_overlap_type(overlap)
7755 type(overlap_type), intent(inout) :: overlap
7758 overlap%
pe = NULL_PE
7760 end subroutine init_overlap_type
7762 !####################################################################
7764 subroutine allocate_update_overlap( overlap, count)
7765 type(overlap_type), intent(inout) :: overlap
7769 overlap%
pe = NULL_PE
7770 if(associated(overlap%tileMe)) call
mpp_error(FATAL, &
7771 "allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
7773 "allocate_update_overlap(mpp_domains_define): count should be a positive integer")
7774 allocate(overlap%tileMe (count), overlap%tileNbr (count) )
7775 allocate(overlap%
is (count), overlap%
ie (count) )
7776 allocate(overlap%
js (count), overlap%
je (count) )
7777 allocate(overlap%dir (count), overlap%rotation(count) )
7778 allocate(overlap%from_contact(count), overlap%
msgsize (count) )
7779 overlap%rotation = ZERO
7780 overlap%from_contact = .FALSE.
7782 end subroutine allocate_update_overlap
7784 !#####################################################################################
7785 subroutine insert_update_overlap(overlap,
pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir,
reverse, symmetry)
7786 type(overlap_type), intent(inout) :: overlap
7788 integer, intent(in ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
7790 logical, optional, intent(in ) ::
reverse, symmetry
7792 logical :: is_reverse, is_symmetry, is_overlapped
7795 is_reverse = .FALSE.
7797 is_symmetry = .FALSE.
7798 if(PRESENT(symmetry)) is_symmetry = symmetry
7802 is_overlapped = .false.
7803 !--- to avoid unnecessary ( duplicate overlap )
for symmetry domain
7804 if(is_symmetry .AND. (dir == 1 .OR. dir == 5)) then ! x-direction
7805 if(
ie .GE.
is .AND.
je .GT.
js ) is_overlapped = .true.
7806 else if(is_symmetry .AND. (dir == 3 .OR. dir == 7)) then ! y-direction
7807 if(
ie .GT.
is .AND.
je .GE.
js ) is_overlapped = .true.
7808 else if(
ie.GE.is .AND.
je.GE.js )then
7809 is_overlapped = .true.
7812 if(is_overlapped) then
7813 if( overlap%count == 0 ) then
7817 "mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
7819 overlap%count = overlap%count+1
7820 count = overlap%count
7822 "mpp_domains_define.inc(insert_update_overlap): number of overlap
is greater than MAXOVERLAP, increase MAXOVERLAP")
7823 overlap%
is(count) =
is 7824 overlap%
ie(count) =
ie 7825 overlap%
js(count) =
js 7826 overlap%
je(count) =
je 7827 overlap%tileMe (count) = 1
7828 overlap%tileNbr(count) = 1
7829 overlap%dir(count) = dir
7831 overlap%rotation(count) = ONE_HUNDRED_EIGHTY
7833 overlap%rotation(count) = ZERO
7837 end subroutine insert_update_overlap
7839 !
##################################################################################### 7840 subroutine insert_overlap_type(overlap,
pe, tileMe, tileNbr,
is,
ie,
js,
je, dir, &
7841 rotation, from_contact)
7842 type(overlap_type), intent(inout) :: overlap
7843 integer, intent(in ) :: tileMe, tileNbr,
pe 7845 integer, intent(in ) :: dir, rotation
7846 logical, intent(in ) :: from_contact
7849 if( overlap%count == 0 ) then
7853 "mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
7855 overlap%count = overlap%count+1
7856 count = overlap%count
7858 "mpp_domains_define.inc(insert_overlap_type): number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7859 overlap%tileMe (count) = tileMe
7860 overlap%tileNbr (count) = tileNbr
7861 overlap%
is (count) =
is 7862 overlap%
ie (count) =
ie 7863 overlap%
js (count) =
js 7864 overlap%
je (count) =
je 7865 overlap%dir (count) = dir
7866 overlap%rotation (count) = rotation
7867 overlap%from_contact(count) = from_contact
7870 end subroutine insert_overlap_type
7873 !#######################################################################
7874 subroutine deallocate_overlap_type( overlap)
7875 type(overlap_type), intent(inout) :: overlap
7877 if(overlap%count == 0) then
7878 if( .NOT. associated(overlap%tileMe)) return
7880 if( .NOT. associated(overlap%tileMe)) call
mpp_error(FATAL, &
7881 "deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
7883 if(ASSOCIATED(overlap%tileMe)) deallocate(overlap%tileMe)
7884 if(ASSOCIATED(overlap%tileNbr)) deallocate(overlap%tileNbr)
7885 if(ASSOCIATED(overlap%
is)) deallocate(overlap%
is)
7886 if(ASSOCIATED(overlap%
ie)) deallocate(overlap%
ie)
7887 if(ASSOCIATED(overlap%
js)) deallocate(overlap%
js)
7888 if(ASSOCIATED(overlap%
je)) deallocate(overlap%
je)
7889 if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir)
7890 if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation)
7891 if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact)
7895 end subroutine deallocate_overlap_type
7897 !#######################################################################
7898 subroutine deallocate_overlapSpec(overlap)
7899 type(overlapSpec), intent(inout) :: overlap
7902 if(ASSOCIATED(overlap%
send)) then
7904 call deallocate_overlap_type(overlap%
send(
n))
7906 deallocate(overlap%
send)
7908 if(ASSOCIATED(overlap%
recv)) then
7910 call deallocate_overlap_type(overlap%
recv(
n))
7912 deallocate(overlap%
recv)
7916 end subroutine deallocate_overlapSpec
7918 !#######################################################################
7919 !--- this routine
add the overlap_in into overlap_out
7920 subroutine add_update_overlap( overlap_out, overlap_in)
7921 type(overlap_type), intent(inout) :: overlap_out
7922 type(overlap_type), intent(in ) :: overlap_in
7923 type(overlap_type) :: overlap
7924 integer :: count, count_in, count_out,
n 7926 !
if overlap_out%count == 0, then just
copy overlap_in to overlap_out
7927 count_in = overlap_in %count
7928 count_out = overlap_out%count
7929 count = count_in+count_out
7931 "mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
7933 if(count_out == 0) then
7934 if(associated(overlap_out%tileMe)) call
mpp_error(FATAL, &
7935 "mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
7936 call allocate_update_overlap(overlap_out, count_in)
7937 overlap_out%
pe = overlap_in%
pe 7940 "mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
7942 call allocate_update_overlap(overlap, count_out)
7943 overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7944 overlap%tileNbr (1:count_out) = overlap_out%tileNbr (1:count_out)
7945 overlap%
is (1:count_out) = overlap_out%
is (1:count_out)
7946 overlap%
ie (1:count_out) = overlap_out%
ie (1:count_out)
7947 overlap%
js (1:count_out) = overlap_out%
js (1:count_out)
7948 overlap%
je (1:count_out) = overlap_out%
je (1:count_out)
7949 overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7950 overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7951 overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
7952 call deallocate_overlap_type(overlap_out)
7953 call allocate_update_overlap(overlap_out, count)
7954 overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7955 overlap_out%tileNbr (1:count_out) = overlap%tileNbr (1:count_out)
7956 overlap_out%
is (1:count_out) = overlap%
is (1:count_out)
7957 overlap_out%
ie (1:count_out) = overlap%
ie (1:count_out)
7958 overlap_out%
js (1:count_out) = overlap%
js (1:count_out)
7959 overlap_out%
je (1:count_out) = overlap%
je (1:count_out)
7960 overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7961 overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7962 overlap_out%index (1:count_out) = overlap%index (1:count_out)
7963 overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
7964 overlap_out%
msgsize (1:count_out) = overlap%
msgsize (1:count_out)
7965 call deallocate_overlap_type(overlap)
7967 overlap_out%count = count
7968 overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7969 overlap_out%tileNbr (count_out+1:count) = overlap_in%tileNbr (1:count_in)
7970 overlap_out%
is (count_out+1:count) = overlap_in%
is (1:count_in)
7971 overlap_out%
ie (count_out+1:count) = overlap_in%
ie (1:count_in)
7972 overlap_out%
js (count_out+1:count) = overlap_in%
js (1:count_in)
7973 overlap_out%
je (count_out+1:count) = overlap_in%
je (1:count_in)
7974 overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7975 overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7976 overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
7978 do
n = count_out+1, count
7979 overlap_out%
msgsize(
n) = (overlap_out%
ie(
n)-overlap_out%
is(
n)+1)*(overlap_out%
je(
n)-overlap_out%
js(
n)+1)
7983 end subroutine add_update_overlap
7985 !##############################################################################
7986 subroutine expand_update_overlap_list(overlapList,
npes)
7987 type(overlap_type), pointer :: overlapList(:)
7989 type(overlap_type), pointer,save :: newlist(:) =>
NULL()
7992 nlist_old =
size(overlaplist(:))
7994 'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
7995 nlist =
min(
npes, 2*nlist_old)
7996 allocate(newlist(nlist))
7998 call add_update_overlap(newlist(
m), overlaplist(
m))
7999 call deallocate_overlap_type(overlapList(
m))
8002 deallocate(overlapList)
8003 overlaplist => newlist
8008 end subroutine expand_update_overlap_list
8010 !##################################################################################
8011 subroutine expand_check_overlap_list(overlaplist,
npes)
8012 type(overlap_type), pointer :: overlaplist(:)
8014 type(overlap_type), pointer,save :: newlist(:) =>
NULL()
8017 nlist_old =
size(overlaplist(:))
8019 'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
8020 nlist =
min(
npes, 2*nlist_old)
8021 allocate(newlist(nlist))
8022 do
m = 1,
size(overlaplist(:))
8023 call add_check_overlap(newlist(
m), overlaplist(
m))
8024 call deallocate_overlap_type(overlapList(
m))
8026 deallocate(overlapList)
8027 overlaplist => newlist
8032 end subroutine expand_check_overlap_list
8035 !###############################################################################
8036 subroutine check_overlap_pe_order(domain, overlap,
name)
8037 type(domain2d), intent(in) :: domain
8038 type(overlapSpec), intent(in) :: overlap
8039 character(
len=*), intent(in) ::
name 8043 !---make sure overlap%nsend and overlap%nrecv
is no larger than MAXLIST
8044 if( overlap%nsend > MAXLIST) call
mpp_error(FATAL, &
8045 "mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
8046 if( overlap%nrecv > MAXLIST) call
mpp_error(FATAL, &
8047 "mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
8049 do
m = 2, overlap%nsend
8052 !-- when
p1 == domain%
pe, pe2 could be any value except domain%
pe 8053 if( pe2 == domain%
pe ) then
8056 "mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
8057 else
if( (pe1 > domain%
pe .AND. pe2 > domain%
pe) .OR. (pe1 < domain%
pe .AND. pe2 < domain%
pe)) then
8058 if( pe2 < pe1 ) then
8061 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
8063 else
if ( pe2 > domain%
pe .AND. pe1 < domain%
pe ) then
8066 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
8071 do
m = 2, overlap%nrecv
8074 !-- when
p1 == domain%
pe, pe2 could be any value except domain%
pe 8075 if( pe2 == domain%
pe ) then
8078 "mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
8079 else
if( (pe1 > domain%
pe .AND. pe2 > domain%
pe) .OR. (pe1 < domain%
pe .AND. pe2 < domain%
pe)) then
8080 if( pe2 > pe1 ) then
8083 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
8085 else
if ( pe2 < domain%
pe .AND. pe1 > domain%
pe ) then
8088 "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
8093 end subroutine check_overlap_pe_order
8096 !###############################################################################
8097 subroutine set_domain_comm_inf(update)
8098 type(overlapSpec), intent(inout) :: update
8106 do
m = 1, update%nrecv
8108 do
n = 1, update%
recv(
m)%count
8111 update%
recv(
m)%totsize = totsize
8113 update%
recv(
m)%start_pos = 0
8115 update%
recv(
m)%start_pos = update%
recv(
m-1)%start_pos + update%
recv(
m-1)%totsize
8117 update%recvsize = update%recvsize + totsize
8120 do
m = 1, update%nsend
8122 do
n = 1, update%
send(
m)%count
8125 update%
send(
m)%totsize = totsize
8127 update%
send(
m)%start_pos = 0
8129 update%
send(
m)%start_pos = update%
send(
m-1)%start_pos + update%
send(
m-1)%totsize
8131 update%sendsize = update%sendsize + totsize
8137 end subroutine set_domain_comm_inf
real(fp), parameter, public half
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_position nbuffersz l_size integer
l_size ! loop over number of fields ke do je do i
l_size ! loop over number of fields ke do je do ie to PE
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> unit
character(len=1), parameter equal
integer, save, private iec
integer, parameter, public no
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
integer, parameter, public up
subroutine, public copy(self, rhs)
integer, parameter, public corner
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT end
integer, pointer refinement
integer(long), parameter true
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_DO_REDISTRIBUTE_3D_(f_in, f_out, d_comm, d_type) integer(LONG_KIND), intent(in) ::f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) ::d_comm MPP_TYPE_, intent(in) ::d_type MPP_TYPE_ ::field_in(d_comm%domain_in%x(1)%data%begin:d_comm%domain_in%x(1)%data%end, &d_comm%domain_in%y(1)%data%begin:d_comm%domain_in%y(1)%data%end, d_comm%ke) pointer(ptr_field_in, field_in) MPP_TYPE_ ::field_out(d_comm%domain_out%x(1)%data%begin:d_comm%domain_out%x(1)%data%end, &d_comm%domain_out%y(1)%data%begin:d_comm%domain_out%y(1)%data%end, d_comm%ke) pointer(ptr_field_out, field_out) type(domain2D), pointer ::domain_in, domain_out integer ::i, j, k, l, n, l_size integer ::is, ie, js, je integer ::ke integer ::list, pos, msgsize integer ::to_pe, from_pe MPP_TYPE_ ::buffer(size(mpp_domains_stack(:))) pointer(ptr, buffer) integer ::buffer_pos, wordlen, errunit!fix ke errunit=stderr() l_size=size(f_out(:)) ! equal to size(f_in(:)) ke=d_comm%ke domain_in=> d_comm domain_in
double * cross(const double *p1, const double *p2)
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************! this routine is used to retrieve scalar boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, &position, complete, tile_count) type(domain2D), intent(in) ::domain MPP_TYPE_, intent(in) ::field(:,:) MPP_TYPE_, intent(inout), optional ::ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) integer, intent(in), optional ::flags, position, tile_count logical, intent(in), optional ::complete MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_, allocatable, dimension(:,:) ::ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D integer ::xcount, ycount integer ::ntile logical ::need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(LONG_KIND), dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save ::f_addrs=-9999 integer(LONG_KIND), dimension(4, MAX_DOMAIN_FIELDS, MAX_TILES), save ::b_addrs=-9999 integer, save ::bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags integer ::buffer_size(4) integer ::max_ntile, tile, update_position, ishift, jshift logical ::do_update, is_complete, set_mismatch character(len=3) ::text MPP_TYPE_ ::d_type type(overlapSpec), pointer ::bound=> NULL() ntile
real(r8), dimension(cast_m, cast_n) p
integer(long), parameter false
l_size ! loop over number of fields ke do j
integer, parameter, public west
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
logical module_is_initialized
l_size ! loop over number of fields ke do je do ie to to_pe
character(len=128) version
real(double), parameter zero
real(fp), parameter, public e
l_size ! loop over number of fields ke do je do ie to is
real(r8), parameter offset
integer, parameter, public global
integer(long_kind) domain_cnt
subroutine, private initialize
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE start
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for sending
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) & T
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call mpp_error(FATAL, 'MPP_TRANSMIT:you cannot transmit to ANY_PE using MPI.') else if(to_pe.NE.NULL_PE) then !no other valid cases except NULL_PE call mpp_error(FATAL
real, dimension(:,:,:), allocatable, private g
l_size ! loop over number of fields ke do je do ie to je msgsize
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this case
integer, parameter, public east
real(fvprc) function, dimension(size(a, 1), size(a, 2)) reverse(A)
type(gsw_result_mpres) n2
real(double), parameter one
integer, dimension(:), pointer io_layout
logical function received(this, seqno)
logical debug_message_passing
integer, save, private isc
type(tms), dimension(nblks), private last
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
integer, parameter, public north
integer, save, private jsc
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) a
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> dimension(MAX_DOMAIN_FIELDS)
real(kind_real), parameter bound
integer, parameter, public cyclic
real(r8), dimension(cast_m, cast_n) t
integer, dimension(:), allocatable pelist
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
integer, save, private jec
l_size ! loop over number of fields ke do je do ie pos
integer, dimension(:), pointer layout
integer, parameter, public order
integer, parameter, public south
real per
Longitude of perihelion with respect to autumnal equinox in NH [degrees].
subroutine, public some(xmap, some_arr, grid_id)
type(taucoeff_type), save, public tc
l_size ! loop over number of fields ke do je do ie to js
integer debug_update_level
integer, parameter, public information
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) MPP_BROADCAST begin