MPI-AMRVAC  3.1
The MPI - Adaptive Mesh Refinement - Versatile Advection Code (development version)
mod_functions_connectivity.t
Go to the documentation of this file.
2 
3 
4  implicit none
5  private
6 
7  public :: get_level_range
8  public :: getigrids
9  public :: build_connectivity
10  contains
11 
12  subroutine get_level_range
13  use mod_forest
15 
16  integer :: level
17 
18  ! determine new finest level
19  do level=refine_max_level,1,-1
20  if (associated(level_tail(level)%node)) then
21  levmax=level
22  exit
23  end if
24  end do
25 
26  ! determine coarsest level
27  do level=1,levmax
28  if (associated(level_tail(level)%node)) then
29  levmin=level
30  exit
31  end if
32  end do
33 
34  end subroutine get_level_range
35 
36  subroutine getigrids
37  use mod_forest
39  implicit none
40 
41  integer :: iigrid, igrid
42 
43  iigrid=0
44  do igrid=1,max_blocks
45  if (igrid_inuse(igrid,mype)) then
46  iigrid=iigrid+1
47  igrids(iigrid)=igrid
48  end if
49  end do
50 
51  igridstail=iigrid
52 
53  end subroutine getigrids
54 
55  subroutine build_connectivity
56  use mod_forest
60 
61  integer :: iigrid, igrid, i^d, my_neighbor_type
62  integer :: iside, idim, ic^d, inc^d, ih^d, icdim
63  type(tree_node_ptr) :: tree, my_neighbor, child
64  logical, dimension(^ND) :: pole
65  logical :: nopole
66  ! Variables to detect special corners for stagger grid
67  integer :: idir,pi^d, mi^d, ph^d, mh^d, ipe_neighbor
68  integer :: nrecvs,nsends
69 
70  ! total size of buffer arrays
71  integer :: nbuff_bc_recv_srl, nbuff_bc_send_srl, nbuff_bc_recv_r, nbuff_bc_send_r, nbuff_bc_recv_p, nbuff_bc_send_p
72 
76  nrecv_fc=0; nsend_fc=0
77  nbuff_bc_recv_srl=0; nbuff_bc_send_srl=0
78  nbuff_bc_recv_r=0; nbuff_bc_send_r=0
79  nbuff_bc_recv_p=0; nbuff_bc_send_p=0
80  if(stagger_grid) nrecv_cc=0; nsend_cc=0
81 
82  do iigrid=1,igridstail; igrid=igrids(iigrid);
83  tree%node => igrid_to_node(igrid,mype)%node
84 
85  {do i^db=-1,1\}
86  ! skip the grid itself
87  if (i^d==0|.and.) then
88  neighbor_type(0^d&,igrid)=0
89  neighbor(1,0^d&,igrid)=igrid
90  neighbor(2,0^d&,igrid)=mype
91  else
92  call find_neighbor(my_neighbor,my_neighbor_type,tree,i^d,pole)
93  nopole=.not.any(pole)
94 
95  select case (my_neighbor_type)
96  ! adjacent to physical boundary
97  case (neighbor_boundary)
98  neighbor(1,i^d,igrid)=0
99  neighbor(2,i^d,igrid)=-1
100  ! fine-coarse transition
101  case (neighbor_coarse)
102  neighbor(1,i^d,igrid)=my_neighbor%node%igrid
103  neighbor(2,i^d,igrid)=my_neighbor%node%ipe
104  if (my_neighbor%node%ipe/=mype) then
105  ic^d=1+modulo(tree%node%ig^d-1,2);
106  if ({(i^d==0.or.i^d==2*ic^d-3)|.and.}) then
109  nbuff_bc_send_r=nbuff_bc_send_r+sizes_r_send_total(i^d)
110  ! This is the local index of the prolonged ghost zone
111  inc^d=ic^d+i^d;
112  nbuff_bc_recv_p=nbuff_bc_recv_p+sizes_p_recv_total(inc^d)
113  end if
114  end if
115  ! same refinement level
116  case (neighbor_sibling)
117  neighbor(1,i^d,igrid)=my_neighbor%node%igrid
118  neighbor(2,i^d,igrid)=my_neighbor%node%ipe
119  if (my_neighbor%node%ipe/=mype) then
122  nbuff_bc_send_srl=nbuff_bc_send_srl+sizes_srl_send_total(i^d)
123  nbuff_bc_recv_srl=nbuff_bc_recv_srl+sizes_srl_recv_total(i^d)
124  end if
125  ! coarse-fine transition
126  case (neighbor_fine)
127  neighbor(1,i^d,igrid)=0
128  neighbor(2,i^d,igrid)=-1
129  ! Loop over the local indices of children ic^D
130  ! and calculate local indices of ghost zone inc^D.
131  {do ic^db=1+int((1-i^db)/2),2-int((1+i^db)/2)
132  inc^db=2*i^db+ic^db
133  if (pole(^db)) then
134  ih^db=3-ic^db
135  else
136  ih^db=ic^db
137  end if\}
138  child%node => my_neighbor%node%child(ih^d)%node
139  neighbor_child(1,inc^d,igrid)=child%node%igrid
140  neighbor_child(2,inc^d,igrid)=child%node%ipe
141  if (child%node%ipe/=mype) then
142  nrecv_bc_r=nrecv_bc_r+1
143  nsend_bc_p=nsend_bc_p+1
144  nbuff_bc_send_p=nbuff_bc_send_p+sizes_p_send_total(inc^d)
145  nbuff_bc_recv_r=nbuff_bc_recv_r+sizes_r_recv_total(inc^d)
146  end if
147  {end do\}
148  end select
149 
150  ! flux fix for conservation only for pure directional shifts
151  if ({abs(i^d)+}==1) then
152  {if (i^d/=0) then
153  idim=^d
154  iside=int((i^d+3)/2)
155  end if\}
156  select case (my_neighbor_type)
157  ! only across fine-coarse or coarse-fine boundaries
158  case (neighbor_coarse)
159  if (my_neighbor%node%ipe/=mype) then
160  if (.not.pole(idim)) nsend_fc(idim)=nsend_fc(idim)+1
161  end if
162  case (neighbor_fine)
163  if (pole(idim)) then
164  icdim=iside
165  else
166  icdim=3-iside
167  end if
168  select case (idim)
169  {case (^d)
170  {do ic^d=icdim,icdim^d%do ic^dd=1,2\}
171  child%node => my_neighbor%node%child(ic^dd)%node
172  if (child%node%ipe/=mype) then
173  if (.not.pole(^d)) nrecv_fc(^d)=nrecv_fc(^d)+1
174  end if
175  {end do\} \}
176  end select
177  end select
178  end if
179 
180  if (phi_ > 0) then
181  neighbor_pole(i^d,igrid)=0
182  if (my_neighbor_type>1) then
183  do idim=1,^nd
184  if (pole(idim)) then
185  neighbor_pole(i^d,igrid)=idim
186  exit ! there can only be one pole between two meshes
187  end if
188  end do
189  end if
190  end if
191  neighbor_type(i^d,igrid)=my_neighbor_type
192 
193  end if
194  {end do\}
195 
196  if(stagger_grid) then
197  !Now all the neighbour information is known.
198  !Check if there are special corners that need to be communicated
199  !To determine whether to send/receive, we must check three neighbours
200  {do i^db=-1,1\}
201  if ({abs(i^d)+}==1) then
202  if (neighbor_pole(i^d,igrid)/=0) cycle
203  ! Assign value to idim and iside
204  {if (i^d/=0) then
205  idim=^d
206  iside=int((i^d+3)/2)
207  end if\}
208  ! Fine block surrounded by coarse blocks
209  if (neighbor_type(i^d,igrid)==2) then
210  do idir=idim+1,ndim
211  pi^d=i^d+kr(idir,^d);
212  mi^d=i^d-kr(idir,^d);
213  ph^d=pi^d-kr(idim,^d)*(2*iside-3);
214  mh^d=mi^d-kr(idim,^d)*(2*iside-3);
215 
216  if (neighbor_type(pi^d,igrid)==2.and.&
217  neighbor_type(ph^d,igrid)==2.and.&
218  mype/=neighbor(2,pi^d,igrid).and.&
219  neighbor_pole(pi^d,igrid)==0) then
220  nsend_cc(idim) = nsend_cc(idim) + 1
221  end if
222 
223  if (neighbor_type(mi^d,igrid)==2.and.&
224  neighbor_type(mh^d,igrid)==2.and.&
225  mype/=neighbor(2,mi^d,igrid).and.&
226  neighbor_pole(mi^d,igrid)==0) then
227  nsend_cc(idim) = nsend_cc(idim) + 1
228  end if
229  end do
230  end if
231  ! Coarse block diagonal to fine block(s)
232  if (neighbor_type(i^d,igrid)==3) then
233  do idir=idim+1,ndim
234  pi^d=i^d+kr(idir,^d);
235  mi^d=i^d-kr(idir,^d);
236  ph^d=pi^d-kr(idim,^d)*(2*iside-3);
237  mh^d=mi^d-kr(idim,^d)*(2*iside-3);
238 
239  if (neighbor_type(pi^d,igrid)==4.and.&
240  neighbor_type(ph^d,igrid)==3.and.&
241  neighbor_pole(pi^d,igrid)==0) then
242  ! Loop on children (several in 3D)
243  {do ic^db=1+int((1-pi^db)/2),2-int((1+pi^db)/2)
244  inc^db=2*pi^db+ic^db\}
245  if (mype.ne.neighbor_child(2,inc^d,igrid)) then
246  nrecv_cc(idim) = nrecv_cc(idim) + 1
247  end if
248  {end do\}
249  end if
250 
251  if (neighbor_type(mi^d,igrid)==4.and.&
252  neighbor_type(mh^d,igrid)==3.and.&
253  neighbor_pole(mi^d,igrid)==0) then
254  ! Loop on children (several in 3D)
255  {do ic^db=1+int((1-mi^db)/2),2-int((1+mi^db)/2)
256  inc^db=2*mi^db+ic^db\}
257  if (mype.ne.neighbor_child(2,inc^d,igrid)) then
258  nrecv_cc(idim) = nrecv_cc(idim) + 1
259  end if
260  {end do\}
261  end if
262  end do
263  end if
264  end if
265  {end do\}
266  end if
267 
268  end do
269 
270  ! allocate space for mpi recieve for siblings and restrict ghost cell filling
271  nrecvs=nrecv_bc_srl+nrecv_bc_r
272  if (allocated(recvstatus_c_sr)) then
273  deallocate(recvstatus_c_sr,recvrequest_c_sr)
274  allocate(recvstatus_c_sr(mpi_status_size,nrecvs),recvrequest_c_sr(nrecvs))
275  else
276  allocate(recvstatus_c_sr(mpi_status_size,nrecvs),recvrequest_c_sr(nrecvs))
277  end if
278  recvrequest_c_sr=mpi_request_null
279 
280  ! allocate space for mpi send for siblings and restrict ghost cell filling
281  nsends=nsend_bc_srl+nsend_bc_r
282  if (allocated(sendstatus_c_sr)) then
283  deallocate(sendstatus_c_sr,sendrequest_c_sr)
284  allocate(sendstatus_c_sr(mpi_status_size,nsends),sendrequest_c_sr(nsends))
285  else
286  allocate(sendstatus_c_sr(mpi_status_size,nsends),sendrequest_c_sr(nsends))
287  end if
288  sendrequest_c_sr=mpi_request_null
289 
290  ! allocate space for mpi recieve for prolongation ghost cell filling
291  if (allocated(recvstatus_c_p)) then
292  deallocate(recvstatus_c_p,recvrequest_c_p)
293  allocate(recvstatus_c_p(mpi_status_size,nrecv_bc_p),recvrequest_c_p(nrecv_bc_p))
294  else
295  allocate(recvstatus_c_p(mpi_status_size,nrecv_bc_p),recvrequest_c_p(nrecv_bc_p))
296  end if
297  recvrequest_c_p=mpi_request_null
298 
299  ! allocate space for mpi send for prolongation ghost cell filling
300  if (allocated(sendstatus_c_p)) then
301  deallocate(sendstatus_c_p,sendrequest_c_p)
302  allocate(sendstatus_c_p(mpi_status_size,nsend_bc_p),sendrequest_c_p(nsend_bc_p))
303  else
304  allocate(sendstatus_c_p(mpi_status_size,nsend_bc_p),sendrequest_c_p(nsend_bc_p))
305  end if
306  sendrequest_c_p=mpi_request_null
307 
308  if(stagger_grid) then
309  ! allocate space for recieve buffer for siblings ghost cell filling
310  if (allocated(recvbuffer_srl)) then
311  if (nbuff_bc_recv_srl /= size(recvbuffer_srl)) then
312  deallocate(recvbuffer_srl)
313  allocate(recvbuffer_srl(nbuff_bc_recv_srl))
314  end if
315  else
316  allocate(recvbuffer_srl(nbuff_bc_recv_srl))
317  end if
318  if (allocated(recvstatus_srl)) then
319  deallocate(recvstatus_srl,recvrequest_srl)
320  allocate(recvstatus_srl(mpi_status_size,nrecv_bc_srl),recvrequest_srl(nrecv_bc_srl))
321  else
322  allocate(recvstatus_srl(mpi_status_size,nrecv_bc_srl),recvrequest_srl(nrecv_bc_srl))
323  end if
324  recvrequest_srl=mpi_request_null
325 
326  ! allocate space for send buffer for siblings ghost cell filling
327  if (allocated(sendbuffer_srl)) then
328  if (nbuff_bc_send_srl /= size(sendbuffer_srl)) then
329  deallocate(sendbuffer_srl)
330  allocate(sendbuffer_srl(nbuff_bc_send_srl))
331  end if
332  else
333  allocate(sendbuffer_srl(nbuff_bc_send_srl))
334  end if
335  if (allocated(sendstatus_srl)) then
336  deallocate(sendstatus_srl,sendrequest_srl)
337  allocate(sendstatus_srl(mpi_status_size,nsend_bc_srl),sendrequest_srl(nsend_bc_srl))
338  else
339  allocate(sendstatus_srl(mpi_status_size,nsend_bc_srl),sendrequest_srl(nsend_bc_srl))
340  end if
341  sendrequest_srl=mpi_request_null
342 
343  ! allocate space for recieve buffer for restrict ghost cell filling
344  if (allocated(recvbuffer_r)) then
345  if (nbuff_bc_recv_r /= size(recvbuffer_r)) then
346  deallocate(recvbuffer_r)
347  allocate(recvbuffer_r(nbuff_bc_recv_r))
348  end if
349  else
350  allocate(recvbuffer_r(nbuff_bc_recv_r))
351  end if
352  if (allocated(recvstatus_r)) then
353  deallocate(recvstatus_r,recvrequest_r)
354  allocate(recvstatus_r(mpi_status_size,nrecv_bc_r),recvrequest_r(nrecv_bc_r))
355  else
356  allocate(recvstatus_r(mpi_status_size,nrecv_bc_r),recvrequest_r(nrecv_bc_r))
357  end if
358  recvrequest_r=mpi_request_null
359 
360  ! allocate space for send buffer for restrict ghost cell filling
361  if (allocated(sendbuffer_r)) then
362  if (nbuff_bc_send_r /= size(sendbuffer_r)) then
363  deallocate(sendbuffer_r)
364  allocate(sendbuffer_r(nbuff_bc_send_r))
365  end if
366  else
367  allocate(sendbuffer_r(nbuff_bc_send_r))
368  end if
369  if (allocated(sendstatus_r)) then
370  deallocate(sendstatus_r,sendrequest_r)
371  allocate(sendstatus_r(mpi_status_size,nsend_bc_r),sendrequest_r(nsend_bc_r))
372  else
373  allocate(sendstatus_r(mpi_status_size,nsend_bc_r),sendrequest_r(nsend_bc_r))
374  end if
375  sendrequest_r=mpi_request_null
376 
377  ! allocate space for recieve buffer for prolong ghost cell filling
378  if (allocated(recvbuffer_p)) then
379  if (nbuff_bc_recv_p /= size(recvbuffer_p)) then
380  deallocate(recvbuffer_p)
381  allocate(recvbuffer_p(nbuff_bc_recv_p))
382  end if
383  else
384  allocate(recvbuffer_p(nbuff_bc_recv_p))
385  end if
386  if (allocated(recvstatus_p)) then
387  deallocate(recvstatus_p,recvrequest_p)
388  allocate(recvstatus_p(mpi_status_size,nrecv_bc_p),recvrequest_p(nrecv_bc_p))
389  else
390  allocate(recvstatus_p(mpi_status_size,nrecv_bc_p),recvrequest_p(nrecv_bc_p))
391  end if
392  recvrequest_p=mpi_request_null
393 
394  ! allocate space for send buffer for restrict ghost cell filling
395  if (allocated(sendbuffer_p)) then
396  if (nbuff_bc_send_p /= size(sendbuffer_p)) then
397  deallocate(sendbuffer_p)
398  allocate(sendbuffer_p(nbuff_bc_send_p))
399  end if
400  else
401  allocate(sendbuffer_p(nbuff_bc_send_p))
402  end if
403  if (allocated(sendstatus_p)) then
404  deallocate(sendstatus_p,sendrequest_p)
405  allocate(sendstatus_p(mpi_status_size,nsend_bc_p),sendrequest_p(nsend_bc_p))
406  else
407  allocate(sendstatus_p(mpi_status_size,nsend_bc_p),sendrequest_p(nsend_bc_p))
408  end if
409  sendrequest_p=mpi_request_null
410  end if
411 
412  end subroutine build_connectivity
413 
subroutine, public find_neighbor(my_neighbor, my_neighbor_type, tree, iD, pole)
find neighors of all blocks
Module with basic grid data structures.
Definition: mod_forest.t:2
logical, dimension(:,:), allocatable, save igrid_inuse
Definition: mod_forest.t:70
type(tree_node_ptr), dimension(:), allocatable, save level_tail
The tail pointer of the linked list per refinement level.
Definition: mod_forest.t:38
type(tree_node_ptr), dimension(:,:), allocatable, save igrid_to_node
Array to go from an [igrid, ipe] index to a node pointer.
Definition: mod_forest.t:32
update ghost cells of all blocks including physical boundaries
integer, dimension(-1:1^d &) sizes_r_send_total
integer, dimension(-1:1^d &) sizes_srl_send_total
integer, dimension(0:3^d &) sizes_p_recv_total
integer, dimension(-1:1^d &) sizes_srl_recv_total
This module contains definitions of global parameters and variables and some generic functions/subrou...
logical stagger_grid
True for using stagger grid.
integer mype
The rank of the current MPI task.
integer, dimension(:), allocatable, parameter d
integer refine_max_level
Maximal number of AMR levels.
integer max_blocks
The maximum number of grid blocks in a processor.
Pointer to a tree_node.
Definition: mod_forest.t:6