26      type(domainug),   
intent(inout) :: UG_domain
 
   27      type(domain2d), 
target,     
intent(in) :: SG_domain
 
   28      integer,                    
intent(in) :: npts_tile(:)
 
   29      integer,                    
intent(in) :: grid_nlev(:)
 
   30      integer,                    
intent(in) :: ndivs
 
   31      integer,                    
intent(in) :: npes_io_group
 
   34      integer,                    
intent(in) :: grid_index(:)
 
   35      character(len=*), 
optional, 
intent(in) :: name
 
   36      integer, 
dimension(size(npts_tile(:))) :: ndivs_tile, pe_start, pe_end
 
   37      integer, 
dimension(0:ndivs-1)          :: ibegin, iend, costs_list
 
   38      integer :: ntiles, ndivs_used, cur_tile
 
   39      integer :: n, ts, te, p, pos, tile_id, ngroup, group_id, my_pos, i
 
   40      integer :: npes_in_group, is, ie, ntotal_costs, max_cost, cur_cost, costs_left
 
   41      integer :: npts_left, ndiv_left, cur_pos, ndiv, prev_cost, ioff
 
   43      integer :: costs(size(npts_tile(:)))
 
   45      ug_domain%SG_domain => sg_domain
 
   46      ntiles = 
size(npts_tile(:))
 
   47      ug_domain%ntiles = ntiles
 
   50      if(sum(npts_tile)<ndivs) 
call mpp_error(fatal, &
 
   51         &  
"mpp_define_unstruct_domain: total number of points is less than ndivs")
 
   53      do n = 1, 
size(grid_nlev(:))
 
   54         if(grid_nlev(n) < 1) 
call mpp_error(fatal, &
 
   55            &  
"mpp_define_unstruct_domain: grid_nlev at some point is less than 1")
 
   62         do i = 1, npts_tile(n)
 
   64            costs(n) = costs(n) + grid_nlev(pos)
 
   68      ntotal_costs = sum(costs)
 
   71         ndivs_tile(n) = ceiling(real(costs(n)*ndivs)/ntotal_costs)
 
   74      ndivs_used = sum(ndivs_tile)
 
   75      do while (ndivs_used > ndivs)
 
   79            if( ndivs_tile(n) > 1 ) 
then 
   80               cur_cost = ceiling(real(costs(n))/(ndivs_tile(n)-1))
 
   81               if( max_cost == 0 .OR. cur_cost<max_cost) 
then 
   87         ndivs_used = ndivs_used-1
 
   88         ndivs_tile(cur_tile) = ndivs_tile(cur_tile) - 1
 
   95         te = ts + ndivs_tile(n) - 1
 
   97         ndiv_left = ndivs_tile(n)
 
   98         npts_left = npts_tile(n)
 
  100         do ndiv = 1, ndivs_tile(n)
 
  102            ibegin(ts+ndiv-1) = cur_pos
 
  103            avg_cost = real(costs_left)/ndiv_left
 
  104            do i = cur_pos, npts_tile(n)
 
  105               cur_cost = cur_cost + grid_nlev(i+ioff)
 
  106               costs_left = costs_left - grid_nlev(i+ioff)
 
  107               if(npts_left < ndiv_left ) 
then 
  108                  call mpp_error(fatal, 
"mpp_define_unstruct_domain: npts_left < ndiv_left")
 
  109               else if(npts_left == ndiv_left ) 
then 
  112               else if(cur_cost .GE. avg_cost) 
then 
  113                  prev_cost = cur_cost - grid_nlev(i+ioff)
 
  117                  else if( cur_cost - avg_cost .LE. avg_cost - prev_cost ) 
then 
  123                     costs_left = costs_left + grid_nlev(i+ioff)
 
  124                     npts_left = npts_left+1
 
  128               npts_left = npts_left-1
 
  130            iend(ts+ndiv-1) = cur_pos - 1
 
  131            costs_list(ts+ndiv-1) = cur_cost
 
  132            ndiv_left = ndiv_left-1
 
  133            npts_left = npts_left-1
 
  137         ioff = ioff+ npts_tile(n)
 
  139      if (
associated(ug_domain%list)) 
deallocate(ug_domain%list) 
 
  140      allocate(ug_domain%list(0:ndivs-1))
 
  142         ug_domain%list(p)%compute%begin = ibegin(p)
 
  143         ug_domain%list(p)%compute%end = iend(p)
 
  144         ug_domain%list(p)%compute%size = ug_domain%list(p)%compute%end - ug_domain%list(p)%compute%begin + 1
 
  145         ug_domain%list(p)%compute%max_size = 0
 
  146         ug_domain%list(p)%pos = p
 
  147         ug_domain%list(p)%pe = p + mpp_root_pe()
 
  150            if( p .GE. pe_start(n) .AND. p .LE. pe_end(n) ) 
then 
  151               ug_domain%list(p)%tile_id = n
 
  154            pos = pos + npts_tile(n)
 
  156         is = ug_domain%list(p)%compute%begin+pos
 
  157         ie = ug_domain%list(p)%compute%end+pos
 
  158         ug_domain%list(p)%compute%begin_index = minval(grid_index(is:ie))
 
  159         ug_domain%list(p)%compute%end_index = maxval(grid_index(is:ie))
 
  163      if(
mpp_pe() == mpp_root_pe() .and. 
present(name)) 
then 
  164         write(
stdout(),*) 
"unstruct domain name = ", trim(name)
 
  165         write(
stdout(),*) ug_domain%list(:)%compute%size
 
  168      pos = 
mpp_pe() - mpp_root_pe()
 
  171      ug_domain%tile_id = ug_domain%list(pos)%tile_id
 
  172      p = pe_start(ug_domain%tile_id)
 
  173      ug_domain%tile_root_pe = ug_domain%list(p)%pe
 
  174      ug_domain%tile_npes = pe_end(ug_domain%tile_id) - pe_start(ug_domain%tile_id) + 1
 
  175      ug_domain%compute = ug_domain%list(pos)%compute
 
  176      ug_domain%compute%max_size = maxval( ug_domain%list(:)%compute%size )
 
  177      ug_domain%global%begin = 1
 
  178      ug_domain%global%end   = npts_tile(ug_domain%tile_id)
 
  179      ug_domain%global%size  = ug_domain%global%end - ug_domain%global%begin + 1
 
  180      ug_domain%global%max_size = -1   
 
  182      do n = 1, ug_domain%tile_id-1
 
  183         pos = pos + npts_tile(n)
 
  185      ug_domain%global%begin_index = grid_index(pos+1)
 
  186      ug_domain%global%end_index = grid_index(pos+npts_tile(n))
 
  188      if (
associated(ug_domain%grid_index)) 
deallocate(ug_domain%grid_index) 
 
  189      allocate(ug_domain%grid_index(ug_domain%compute%size))
 
  190      do n = 1, ug_domain%compute%size
 
  191         ug_domain%grid_index(n) = grid_index(pos+ug_domain%compute%begin+n-1)
 
  195      if (
associated(ug_domain%io_domain)) 
deallocate(ug_domain%io_domain) 
 
  196      allocate(ug_domain%io_domain)
 
  197      tile_id = ug_domain%tile_id
 
  198      ug_domain%io_domain%pe = ug_domain%pe
 
  200      if(npes_io_group == 0) 
then 
  203         ngroup = ceiling(real(ndivs_tile(tile_id))/ npes_io_group)
 
  208      ug_domain%npes_io_group = npes_io_group
 
  209      ug_domain%io_layout = ngroup
 
  212      call mpp_compute_extent(1, ndivs_tile(tile_id), ngroup, ibegin(0:ngroup-1), iend(0:ngroup-1))
 
  213      my_pos = ug_domain%pe - ug_domain%tile_root_pe + 1
 
  215         if( my_pos .GE. ibegin(n) .AND. my_pos .LE. iend(n) ) 
then 
  221      ug_domain%io_domain%tile_id            = group_id+1
 
  222      ug_domain%io_domain%compute            = ug_domain%compute
 
  223      ug_domain%io_domain%pe                 = ug_domain%pe
 
  224      ug_domain%io_domain%pos                = my_pos - ibegin(group_id) + 1
 
  225      ug_domain%io_domain%tile_root_pe       = ibegin(group_id) + ug_domain%tile_root_pe - 1
 
  226      pos = ug_domain%io_domain%tile_root_pe - mpp_root_pe()
 
  227      ug_domain%io_domain%global%begin       = ug_domain%list(pos)%compute%begin
 
  228      ug_domain%io_domain%global%begin_index = ug_domain%list(pos)%compute%begin_index
 
  229      pos = iend(group_id) + ug_domain%tile_root_pe - mpp_root_pe() - 1
 
  230      ug_domain%io_domain%global%end         = ug_domain%list(pos)%compute%end
 
  231      ug_domain%io_domain%global%end_index   = ug_domain%list(pos)%compute%end_index
 
  232      ug_domain%io_domain%global%size        = ug_domain%io_domain%global%end -  ug_domain%io_domain%global%begin + 1
 
  234      npes_in_group = iend(group_id) - ibegin(group_id) + 1
 
  235      if (
associated(ug_domain%io_domain%list)) 
deallocate(ug_domain%io_domain%list) 
 
  236      allocate(ug_domain%io_domain%list(0:npes_in_group-1))
 
  237      do n = 0, npes_in_group-1
 
  238         pos = ug_domain%io_domain%tile_root_pe - mpp_root_pe() + n
 
  239         ug_domain%io_domain%list(n)%compute = ug_domain%list(pos)%compute
 
  240         ug_domain%io_domain%list(n)%pos = n
 
  241         ug_domain%io_domain%list(n)%pe = ug_domain%list(pos)%pe
 
  242         ug_domain%io_domain%list(n)%tile_id = group_id+1
 
  245      call compute_overlap_sg2ug(ug_domain, sg_domain)
 
  246      call compute_overlap_ug2sg(ug_domain)
 
  254   subroutine compute_overlap_sg2ug(UG_domain, SG_domain)
 
  255      type(domainug),   
intent(inout) :: UG_domain
 
  256      type(domain2d),             
intent(in) :: SG_domain
 
  257      integer, 
dimension(0:size(SG_domain%list(:))-1) :: send_cnt, recv_cnt
 
  258      integer, 
dimension(0:size(SG_domain%list(:))-1) :: send_buffer_pos, recv_buffer_pos
 
  259      integer, 
dimension(:), 
allocatable              :: send_buffer, recv_buffer, index_list
 
  260      integer, 
dimension(:), 
allocatable              :: buffer_pos
 
  261      integer :: tile_id, nlist, nxg, begin_index, end_index, i, j
 
  262      integer :: m, n, list, l, isc, iec, jsc, jec, ibegin, iend, grid_index
 
  263      integer :: nrecv, nsend, send_pos, recv_pos, pos
 
  266      tile_id = ug_domain%tile_id
 
  267      nlist = 
size(sg_domain%list(:))
 
  268      nxg = sg_domain%x(1)%global%size
 
  269      begin_index = ug_domain%compute%begin_index
 
  270      end_index = ug_domain%compute%end_index
 
  273      allocate(index_list(ug_domain%compute%size))
 
  274      allocate(send_buffer(ug_domain%compute%size))
 
  277         if(sg_domain%list(n)%tile_id(1) .NE. tile_id) cycle
 
  278         isc = sg_domain%list(n)%x(1)%compute%begin; iec = sg_domain%list(n)%x(1)%compute%end
 
  279         jsc = sg_domain%list(n)%y(1)%compute%begin; jec = sg_domain%list(n)%y(1)%compute%end
 
  280         ibegin = (jsc-1)*nxg + isc
 
  281         iend   = (jec-1)*nxg + iec
 
  282         if(ibegin > end_index .OR. iend < begin_index) cycle
 
  283         do l = 1, ug_domain%compute%size
 
  284            grid_index = ug_domain%grid_index(l)
 
  285            i = mod((grid_index-1), nxg) + 1
 
  286            j = (grid_index-1)/nxg + 1
 
  287            if( i .GE. isc .AND. i .LE. iec .and. j .GE. jsc .AND. j .LE. jec ) 
then 
  288               recv_cnt(n) = recv_cnt(n) + 1
 
  290               if(pos > ug_domain%compute%size) 
call mpp_error(fatal, &
 
  291                   'compute_overlap_SG2UG: pos > UG_domain%compute%size')
 
  293               send_buffer(pos) = grid_index
 
  299      if( ug_domain%compute%size .NE. sum(recv_cnt) ) 
then 
  300         print*,
"pe=", 
mpp_pe(), ug_domain%compute%size, sum(recv_cnt)
 
  301         call mpp_error(fatal, &
 
  302           .NE.
"compute_overlap_SG2UG: UG_domain%compute%size  sum(recv_cnt)")
 
  304      allocate(buffer_pos(0:nlist-1))
 
  307         buffer_pos(list) = pos
 
  308         pos = pos + recv_cnt(list)
 
  311      nrecv = count( recv_cnt > 0 )
 
  312      ug_domain%SG2UG%nrecv = nrecv
 
  313      if (
associated(ug_domain%SG2UG%recv)) 
deallocate(ug_domain%SG2UG%recv) 
 
  314      allocate(ug_domain%SG2UG%recv(nrecv))
 
  318         m = mod( sg_domain%pos+nlist-list, nlist )
 
  319         if( recv_cnt(m) > 0 ) 
then 
  321            ug_domain%SG2UG%recv(nrecv)%count = recv_cnt(m)
 
  322            ug_domain%SG2UG%recv(nrecv)%pe = ug_domain%list(m)%pe
 
  323            allocate(ug_domain%SG2UG%recv(nrecv)%i(recv_cnt(m)))
 
  325            do l = 1, recv_cnt(m)
 
  327               ug_domain%SG2UG%recv(nrecv)%i(l) = index_list(pos)
 
  335      call mpp_alltoall(send_cnt,1,recv_cnt,1)
 
  337      if( ug_domain%compute%size .NE. sum(send_cnt) ) 
call mpp_error(fatal, &
 
  338           .NE.
"compute_overlap_SG2UG: UG_domain%compute%size  sum(send_cnt)")
 
  339      allocate(recv_buffer(sum(recv_cnt)))
 
  340      send_buffer_pos = 0; recv_buffer_pos = 0
 
  341      send_pos = 0; recv_pos = 0
 
  343         if(send_cnt(n) > 0) 
then 
  344            send_buffer_pos(n) = send_pos
 
  345            send_pos = send_pos + send_cnt(n)
 
  347         if(recv_cnt(n) > 0) 
then 
  348            recv_buffer_pos(n) = recv_pos
 
  349            recv_pos = recv_pos + recv_cnt(n)
 
  353      call mpp_alltoall(send_buffer, send_cnt, send_buffer_pos, &
 
  354                        recv_buffer, recv_cnt, recv_buffer_pos)
 
  356      nsend = count( recv_cnt(:) > 0 )
 
  357      ug_domain%SG2UG%nsend = nsend
 
  358      if (
associated(ug_domain%SG2UG%send)) 
deallocate(ug_domain%SG2UG%send) 
 
  359      allocate(ug_domain%SG2UG%send(nsend))
 
  361      isc = sg_domain%x(1)%compute%begin
 
  362      jsc = sg_domain%y(1)%compute%begin
 
  364         m = mod( sg_domain%pos+list, nlist )
 
  365         if( recv_cnt(m) > 0 ) 
then 
  367            ug_domain%SG2UG%send(nsend)%count = recv_cnt(m)
 
  368            ug_domain%SG2UG%send(nsend)%pe = ug_domain%list(m)%pe
 
  369            allocate(ug_domain%SG2UG%send(nsend)%i(recv_cnt(m)))
 
  370            allocate(ug_domain%SG2UG%send(nsend)%j(recv_cnt(m)))
 
  371            pos = recv_buffer_pos(m)
 
  372            do l = 1, recv_cnt(m)
 
  373               grid_index = recv_buffer(pos+l)
 
  374               ug_domain%SG2UG%send(nsend)%i(l) = mod(grid_index-1,nxg) + 1
 
  375               ug_domain%SG2UG%send(nsend)%j(l) = (grid_index-1)/nxg + 1
 
  379      deallocate(send_buffer, recv_buffer, index_list, buffer_pos)
 
  383   end subroutine compute_overlap_sg2ug
 
  386   subroutine compute_overlap_ug2sg(UG_domain)
 
  387      type(domainug),   
intent(inout) :: UG_domain
 
  390      ug_domain%UG2SG%nsend = ug_domain%SG2UG%nrecv
 
  391      ug_domain%UG2SG%send => ug_domain%SG2UG%recv
 
  392      ug_domain%UG2SG%nrecv = ug_domain%SG2UG%nsend
 
  393      ug_domain%UG2SG%recv => ug_domain%SG2UG%send
 
  397   end subroutine compute_overlap_ug2sg
 
  400   subroutine mpp_get_ug_sg_domain(UG_domain,SG_domain)
 
  401      type(domainug),   
intent(inout) :: UG_domain
 
  402      type(domain2d),   
pointer       :: SG_domain
 
  404      sg_domain => ug_domain%SG_domain
 
  408   end subroutine mpp_get_ug_sg_domain
 
  411   function mpp_get_ug_io_domain(domain)
 
  412      type(domainug), 
intent(in) :: domain
 
  413      type(domainug), 
pointer    :: mpp_get_UG_io_domain
 
  415      if(
ASSOCIATED(domain%io_domain)) 
then 
  416         mpp_get_ug_io_domain => domain%io_domain
 
  418         call mpp_error(fatal, 
"mpp_get_UG_io_domain: io_domain is not defined, contact developer")
 
  421   end function mpp_get_ug_io_domain
 
  424   subroutine mpp_get_ug_compute_domain( domain, begin, end, size)
 
  425     type(domainug),  
intent(in) :: domain
 
  426     integer, 
intent(out), 
optional :: begin, end, size
 
  428     if( 
PRESENT(begin)     )begin     = domain%compute%begin
 
  429     if( 
PRESENT(
end)       )end       = domain%compute%end
 
  430     if( 
PRESENT(size)      )
size      = domain%compute%size
 
  432   end subroutine mpp_get_ug_compute_domain
 
  435   subroutine mpp_get_ug_global_domain( domain, begin, end, size)
 
  436     type(domainug),  
intent(in) :: domain
 
  437     integer, 
intent(out), 
optional :: begin, end, size
 
  439     if( 
PRESENT(begin)     )begin     = domain%global%begin
 
  440     if( 
PRESENT(
end)       )end       = domain%global%end
 
  441     if( 
PRESENT(size)      )
size      = domain%global%size
 
  443   end subroutine mpp_get_ug_global_domain
 
  446   subroutine mpp_get_ug_compute_domains( domain, begin, end, size )
 
  447     type(domainug),                   
intent(in) :: domain
 
  448     integer, 
intent(out), 
optional, 
dimension(:) :: begin, end, size
 
  451     if( 
PRESENT(begin) )
then 
  452        if( any(shape(begin).NE.shape(domain%list)) ) &
 
  453             call mpp_error( fatal, 
'mpp_get_UG_compute_domains: begin array size does not match domain.' )
 
  454        begin(:) = domain%list(:)%compute%begin
 
  456     if( 
PRESENT(
end) )then
 
  457        if( any(shape(
end).NE.shape(domain%list)) ) &
 
  458             call mpp_error( fatal, 
'mpp_get_UG_compute_domains: end array size does not match domain.' )
 
  459             end(:) = domain%list(:)%compute%end
 
  461     if( 
PRESENT(size) )
then 
  462        if( any(shape(size).NE.shape(domain%list)) ) &
 
  463            call mpp_error( fatal, 
'mpp_get_UG_compute_domains: size array size does not match domain.' )
 
  464        size(:) = domain%list(:)%compute%size
 
  467   end subroutine mpp_get_ug_compute_domains
 
  470   subroutine mpp_get_ug_domains_index( domain, begin, end)
 
  471     type(domainug),         
intent(in) :: domain
 
  472     integer, 
intent(out), 
dimension(:) :: begin, end
 
  475     if( any(shape(begin).NE.shape(domain%list)) ) &
 
  476          call mpp_error( fatal, 
'mpp_get_UG_compute_domains: begin array size does not match domain.' )
 
  477     begin(:) = domain%list(:)%compute%begin_index
 
  478     if( any(shape(
end).NE.shape(domain%list)) ) &
 
  479          call mpp_error( fatal, 
'mpp_get_UG_compute_domains: end array size does not match domain.' )
 
  480          end(:) = domain%list(:)%compute%end_index
 
  482   end subroutine mpp_get_ug_domains_index
 
  485   function mpp_get_ug_domain_ntiles(domain)
 
  486     type(domainug),  
intent(in) :: domain
 
  487     integer :: mpp_get_UG_domain_ntiles
 
  489     mpp_get_ug_domain_ntiles = domain%ntiles
 
  491   end function mpp_get_ug_domain_ntiles
 
  494   subroutine mpp_get_ug_domain_tile_list(domain, tiles)
 
  495      type(domainug), 
intent(in) :: domain
 
  496      integer,     
intent(inout) :: tiles(:)
 
  499      if( 
size(tiles(:)).NE.
size(domain%list(:)) ) &
 
  500          call mpp_error( fatal, 
'mpp_get_ug_domain_tile_list: tiles array size does not match domain.' )
 
  501      do i = 1, 
size(tiles(:))
 
  502         tiles(i) = domain%list(i-1)%tile_id
 
  505   end subroutine mpp_get_ug_domain_tile_list
 
  508   function mpp_get_ug_domain_tile_id(domain)
 
  509     type(domainug),  
intent(in) :: domain
 
  510     integer :: mpp_get_UG_domain_tile_id
 
  512     mpp_get_ug_domain_tile_id = domain%tile_id
 
  514   end function mpp_get_ug_domain_tile_id
 
  517   function mpp_get_ug_domain_npes(domain)
 
  518      type(domainug), 
intent(in) :: domain
 
  519      integer :: mpp_get_UG_domain_npes
 
  521      mpp_get_ug_domain_npes = 
size(domain%list(:))
 
  524   end function mpp_get_ug_domain_npes
 
  528   subroutine mpp_get_ug_domain_pelist( domain, pelist)
 
  529      type(domainug), 
intent(in) :: domain
 
  530      integer,              
intent(out) :: pelist(:)
 
  532      if( 
size(pelist(:)).NE.
size(domain%list(:)) ) &
 
  533          call mpp_error( fatal, 
'mpp_get_UG_domain_pelist: pelist array size does not match domain.' )
 
  535      pelist(:) = domain%list(:)%pe
 
  538   end subroutine mpp_get_ug_domain_pelist
 
  541   subroutine mpp_get_ug_domain_tile_pe_inf( domain, root_pe, npes, pelist)
 
  542      type(domainug),     
intent(in) :: domain
 
  543      integer, 
optional, 
intent(out) :: root_pe, npes
 
  544      integer, 
optional, 
intent(out) :: pelist(:)
 
  546      if(
present(root_pe)) root_pe = domain%tile_root_pe
 
  547      if(
present(npes)) npes = domain%tile_npes
 
  549      if(
present(pelist)) 
then 
  550         if( 
size(pelist(:)).NE. domain%tile_npes ) &
 
  551            call mpp_error( fatal, 
'mpp_get_UG_domain_tile_pe_inf: pelist array size does not match domain.' )
 
  552         pelist(:) = domain%list(domain%pos:domain%pos+domain%tile_npes-1)%pe
 
  556   end subroutine mpp_get_ug_domain_tile_pe_inf
 
  560   subroutine mpp_get_ug_domain_grid_index( domain, grid_index)
 
  561      type(domainug), 
intent(in) :: domain
 
  562      integer,              
intent(out) :: grid_index(:)
 
  564      if( 
size(grid_index(:)).NE.
size(domain%grid_index(:)) ) &
 
  565          call mpp_error( fatal, 
'mpp_get_UG_domain_grid_index: grid_index array size does not match domain.' )
 
  567      grid_index(:) = domain%grid_index(:)
 
  570   end subroutine mpp_get_ug_domain_grid_index
 
  573   subroutine mpp_define_null_ug_domain(domain)
 
  574      type(domainug), 
intent(inout) :: domain
 
  576      domain%global%begin  = -1; domain%global%end  = -1; domain%global%size = 0
 
  577      domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
 
  582      domain%tile_root_pe = -1
 
  584   end subroutine mpp_define_null_ug_domain
 
  589       type(domainug), 
intent(inout) :: domain
 
  590       integer, 
allocatable :: pes(:)
 
  592       integer :: listsize, listpos
 
  594       integer, 
dimension(7) :: msg, info         
 
  598       if( .NOT.module_is_initialized ) &
 
  599                  call mpp_error( fatal, 
'MPP_BROADCAST_DOMAIN_ug: You must first call mpp_domains_init.' )
 
  603       call mpp_get_current_pelist(pes)
 
  606       native = 
ASSOCIATED(domain%list)
 
  610           listsize = 
size(domain%list(:))
 
  614       call mpp_max(listsize)
 
  616       if( .NOT.native )
then 
  618          if (
associated(domain%list)) 
deallocate(domain%list) 
 
  619           allocate( domain%list(0:listsize-1) )
 
  623           domain%compute%begin =  1
 
  624           domain%compute%end   = -1
 
  625           domain%compute%begin_index =  1
 
  626           domain%compute%end_index   = -1
 
  627           domain%global %begin = -1
 
  628           domain%global %end   = -1
 
  630           domain%tile_root_pe  = -1
 
  635       info(3) = domain%tile_id
 
  636       call mpp_get_ug_compute_domain( domain, info(4), info(5))
 
  637       info(6) = domain%compute%begin_index
 
  638       info(7) = domain%compute%end_index
 
  643          if( 
mpp_pe().EQ.pes(n) .AND. debug )
write( errunit,* )
'PE ', 
mpp_pe(), 
'broadcasting msg ', msg
 
  644          call mpp_broadcast( msg, 7, pes(n) )
 
  647          if( .NOT.native .AND. msg(1).NE.null_pe )
then 
  648              domain%list(listpos)%pe            = msg(1)
 
  649              domain%list(listpos)%pos           = msg(2)
 
  650              domain%list(listpos)%tile_id       = msg(3)
 
  651              domain%list(listpos)%compute%begin = msg(4)
 
  652              domain%list(listpos)%compute%end   = msg(5)
 
  653              domain%list(listpos)%compute%begin_index = msg(6)
 
  654              domain%list(listpos)%compute%end_index   = msg(7)
 
  655              listpos = listpos + 1
 
  656              if( debug )
write( errunit,* )
'PE ', 
mpp_pe(), 
'received domain from PE ', msg(1), 
'ls,le=', msg(4:5)
 
  663 function mpp_domain_ug_is_tile_root_pe(domain) 
result(is_root)
 
  666     type(domainug),
intent(in) :: domain
 
  667     logical(l8_kind)         :: is_root
 
  669     if (domain%pe .eq. domain%tile_root_pe) 
then 
  676 end function mpp_domain_ug_is_tile_root_pe
 
  682 function mpp_get_io_domain_ug_layout(domain) 
result(io_layout)
 
  685     type(domainug),
intent(in) :: domain
 
  686     integer(i4_kind)         :: io_layout
 
  688     io_layout = domain%io_layout
 
  695 subroutine deallocate_unstruct_overlap_type(overlap)
 
  696   type(unstruct_overlap_type), 
intent(inout) :: overlap
 
  698   if(
associated(overlap%i)) 
deallocate(overlap%i)
 
  699   if(
associated(overlap%j)) 
deallocate(overlap%j)
 
  701 end subroutine deallocate_unstruct_overlap_type
 
  704 subroutine deallocate_unstruct_pass_type(domain)
 
  705   type(domainug), 
intent(inout) :: domain
 
  708   do n = 1, domain%UG2SG%nsend
 
  709      call deallocate_unstruct_overlap_type(domain%UG2SG%send(n))
 
  711   do n = 1, domain%UG2SG%nrecv
 
  712      call deallocate_unstruct_overlap_type(domain%UG2SG%recv(n))
 
  718   if(
associated(domain%UG2SG%send)) 
then 
  719     deallocate(domain%UG2SG%send)
 
  720     nullify(domain%UG2SG%send)
 
  721     nullify(domain%SG2UG%recv)
 
  723   if(
associated(domain%UG2SG%recv)) 
then 
  724     deallocate(domain%UG2SG%recv)
 
  725     nullify(domain%UG2SG%recv)
 
  726     nullify(domain%SG2UG%send)
 
  728 end subroutine deallocate_unstruct_pass_type
 
  731 subroutine mpp_deallocate_domainug(domain)
 
  734     type(domainug),
intent(inout) :: domain
 
  736     if (
associated(domain%list)) 
then 
  737         deallocate(domain%list)
 
  738         domain%list => null()
 
  741     if (
associated(domain%io_domain)) 
then 
  742         if (
associated(domain%io_domain%list)) 
then 
  743             deallocate(domain%io_domain%list)
 
  744             domain%io_domain%list => null()
 
  746         deallocate(domain%io_domain)
 
  747         domain%io_domain => null()
 
  750     call deallocate_unstruct_pass_type(domain)
 
  752     if (
associated(domain%grid_index)) 
then 
  753         deallocate(domain%grid_index)
 
  754         domain%grid_index => null()
 
  757     if (
associated(domain%SG_domain)) 
then 
  758         domain%SG_domain => null()
 
  762 end subroutine mpp_deallocate_domainug
 
  768     type(domainug), 
intent(in) :: a, b
 
  770     if (
associated(a%SG_domain) .and. 
associated(b%SG_domain)) 
then 
  771         if (a%SG_domain .ne. b%SG_domain) 
then 
  775     elseif (
associated(a%SG_domain) .and. .not. 
associated(b%SG_domain)) 
then 
  778     elseif (.not. 
associated(a%SG_domain) .and. 
associated(b%SG_domain)) 
then 
  784                       (a%pos .EQ. b%pos)                     .AND. &
 
  785                       (a%ntiles .EQ. b%ntiles)               .AND. &
 
  786                       (a%tile_id .EQ. b%tile_id)             .AND. &
 
  787                       (a%tile_npes .EQ. b%tile_npes)         .AND. &
 
  788                       (a%tile_root_pe .EQ. b%tile_root_pe)
 
  793          a%compute%end  .EQ.b%compute%end   .AND. &
 
  794          a%global%begin .EQ.b%global%begin  .AND. &
 
  795          a%global%end   .EQ.b%global%end    .AND. &
 
  796          a%SG2UG%nsend  .EQ.b%SG2UG%nsend   .AND. &
 
  797          a%SG2UG%nrecv  .EQ.b%SG2UG%nrecv   .AND. &
 
  798          a%UG2SG%nsend  .EQ.b%UG2SG%nsend   .AND. &
 
  799          a%UG2SG%nrecv  .EQ.b%UG2SG%nrecv         &
 
  808     type(domainug), 
intent(in) :: a, b
 
  815 #define MPP_TYPE_ real(r8_kind) 
  816 #undef mpp_pass_SG_to_UG_2D_ 
  817 #define mpp_pass_SG_to_UG_2D_ mpp_pass_SG_to_UG_r8_2d 
  818 #undef mpp_pass_SG_to_UG_3D_ 
  819 #define mpp_pass_SG_to_UG_3D_ mpp_pass_SG_to_UG_r8_3d 
  820 #undef mpp_pass_UG_to_SG_2D_ 
  821 #define mpp_pass_UG_to_SG_2D_ mpp_pass_UG_to_SG_r8_2d 
  822 #undef mpp_pass_UG_to_SG_3D_ 
  823 #define mpp_pass_UG_to_SG_3D_ mpp_pass_UG_to_SG_r8_3d 
  824 #include <mpp_unstruct_pass_data.fh> 
  827 #define MPP_TYPE_ real(r4_kind) 
  828 #undef mpp_pass_SG_to_UG_2D_ 
  829 #define mpp_pass_SG_to_UG_2D_ mpp_pass_SG_to_UG_r4_2d 
  830 #undef mpp_pass_SG_to_UG_3D_ 
  831 #define mpp_pass_SG_to_UG_3D_ mpp_pass_SG_to_UG_r4_3d 
  832 #undef mpp_pass_UG_to_SG_2D_ 
  833 #define mpp_pass_UG_to_SG_2D_ mpp_pass_UG_to_SG_r4_2d 
  834 #undef mpp_pass_UG_to_SG_3D_ 
  835 #define mpp_pass_UG_to_SG_3D_ mpp_pass_UG_to_SG_r4_3d 
  836 #include <mpp_unstruct_pass_data.fh> 
  839 #define MPP_TYPE_ integer(i4_kind) 
  840 #undef mpp_pass_SG_to_UG_2D_ 
  841 #define mpp_pass_SG_to_UG_2D_ mpp_pass_SG_to_UG_i4_2d 
  842 #undef mpp_pass_SG_to_UG_3D_ 
  843 #define mpp_pass_SG_to_UG_3D_ mpp_pass_SG_to_UG_i4_3d 
  844 #undef mpp_pass_UG_to_SG_2D_ 
  845 #define mpp_pass_UG_to_SG_2D_ mpp_pass_UG_to_SG_i4_2d 
  846 #undef mpp_pass_UG_to_SG_3D_ 
  847 #define mpp_pass_UG_to_SG_3D_ mpp_pass_UG_to_SG_i4_3d 
  848 #include <mpp_unstruct_pass_data.fh> 
  851 #define MPP_TYPE_ logical(i4_kind) 
  852 #undef mpp_pass_SG_to_UG_2D_ 
  853 #define mpp_pass_SG_to_UG_2D_ mpp_pass_SG_to_UG_l4_2d 
  854 #undef mpp_pass_SG_to_UG_3D_ 
  855 #define mpp_pass_SG_to_UG_3D_ mpp_pass_SG_to_UG_l4_3d 
  856 #undef mpp_pass_UG_to_SG_2D_ 
  857 #define mpp_pass_UG_to_SG_2D_ mpp_pass_UG_to_SG_l4_2d 
  858 #undef mpp_pass_UG_to_SG_3D_ 
  859 #define mpp_pass_UG_to_SG_3D_ mpp_pass_UG_to_SG_l4_3d 
  860 #include <mpp_unstruct_pass_data.fh> 
  862 #undef MPP_GLOBAL_FIELD_UG_2D_ 
  863 #define MPP_GLOBAL_FIELD_UG_2D_ mpp_global_field2D_ug_r8_2d 
  864 #undef MPP_GLOBAL_FIELD_UG_3D_ 
  865 #define MPP_GLOBAL_FIELD_UG_3D_ mpp_global_field2D_ug_r8_3d 
  866 #undef MPP_GLOBAL_FIELD_UG_4D_ 
  867 #define MPP_GLOBAL_FIELD_UG_4D_ mpp_global_field2D_ug_r8_4d 
  868 #undef MPP_GLOBAL_FIELD_UG_5D_ 
  869 #define MPP_GLOBAL_FIELD_UG_5D_ mpp_global_field2D_ug_r8_5d 
  871 #define MPP_TYPE_ real(r8_kind) 
  872 #include <mpp_global_field_ug.fh> 
  874 #undef MPP_GLOBAL_FIELD_UG_2D_ 
  875 #define MPP_GLOBAL_FIELD_UG_2D_ mpp_global_field2D_ug_i8_2d 
  876 #undef MPP_GLOBAL_FIELD_UG_3D_ 
  877 #define MPP_GLOBAL_FIELD_UG_3D_ mpp_global_field2D_ug_i8_3d 
  878 #undef MPP_GLOBAL_FIELD_UG_4D_ 
  879 #define MPP_GLOBAL_FIELD_UG_4D_ mpp_global_field2D_ug_i8_4d 
  880 #undef MPP_GLOBAL_FIELD_UG_5D_ 
  881 #define MPP_GLOBAL_FIELD_UG_5D_ mpp_global_field2D_ug_i8_5d 
  883 #define MPP_TYPE_ integer(i8_kind) 
  884 #include <mpp_global_field_ug.fh> 
  886 #undef MPP_GLOBAL_FIELD_UG_2D_ 
  887 #define MPP_GLOBAL_FIELD_UG_2D_ mpp_global_field2D_ug_r4_2d 
  888 #undef MPP_GLOBAL_FIELD_UG_3D_ 
  889 #define MPP_GLOBAL_FIELD_UG_3D_ mpp_global_field2D_ug_r4_3d 
  890 #undef MPP_GLOBAL_FIELD_UG_4D_ 
  891 #define MPP_GLOBAL_FIELD_UG_4D_ mpp_global_field2D_ug_r4_4d 
  892 #undef MPP_GLOBAL_FIELD_UG_5D_ 
  893 #define MPP_GLOBAL_FIELD_UG_5D_ mpp_global_field2D_ug_r4_5d 
  895 #define MPP_TYPE_ real(r4_kind) 
  896 #include <mpp_global_field_ug.fh> 
  898 #undef MPP_GLOBAL_FIELD_UG_2D_ 
  899 #define MPP_GLOBAL_FIELD_UG_2D_ mpp_global_field2D_ug_i4_2d 
  900 #undef MPP_GLOBAL_FIELD_UG_3D_ 
  901 #define MPP_GLOBAL_FIELD_UG_3D_ mpp_global_field2D_ug_i4_3d 
  902 #undef MPP_GLOBAL_FIELD_UG_4D_ 
  903 #define MPP_GLOBAL_FIELD_UG_4D_ mpp_global_field2D_ug_i4_4d 
  904 #undef MPP_GLOBAL_FIELD_UG_5D_ 
  905 #define MPP_GLOBAL_FIELD_UG_5D_ mpp_global_field2D_ug_i4_5d 
  907 #define MPP_TYPE_ integer(i4_kind) 
  908 #include <mpp_global_field_ug.fh> 
subroutine mpp_define_unstruct_domain(UG_domain, SG_domain, npts_tile, grid_nlev, ndivs, npes_io_group, grid_index, name)
logical function mpp_domainug_ne(a, b)
Overload the .ne. for UG.
subroutine mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
Computes extents for a grid decomposition with the given indices and divisions.
subroutine mpp_broadcast_domain_ug(domain)
Broadcast domain (useful only outside the context of its own pelist)
logical function mpp_domainug_eq(a, b)
Overload the .eq. for UG.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.