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