2D AMRCLAW
Functions/Subroutines
baseCheck.f File Reference

Go to the source code of this file.

Functions/Subroutines

logical function basecheck (mnew, lbase, ilo, ihi, jlo, jhi, nvar, naux, thisBuff)
 Check that potential grid mnew is completely contained in coarser grids at level lbase (>1) that will stay fixed during this regridding step. More...
 

Function/Subroutine Documentation

◆ basecheck()

logical function basecheck (   mnew,
  lbase,
  ilo,
  ihi,
  jlo,
  jhi,
  nvar,
  naux,
integer  thisBuff 
)

Check that potential grid mnew is completely contained in coarser grids at level lbase (>1) that will stay fixed during this regridding step.

This version tries to do it without using domflags slower but better if cant afford memory over entire domain

For a grid mnew, find the smallest rectangle expressed in lbase index space and compare it to each grid on level lbase. If every region in the rectangle has been overlapped during the comparison, the grid mnew is properly nested and the function returns true

Definition at line 21 of file baseCheck.f.

References amr_module::alloc, iadd(), igetsp(), amr_module::intratx, amr_module::intraty, amr_module::iregsz, amr_module::jregsz, amr_module::levelptr, amr_module::lstart, amr_module::ndihi, amr_module::ndilo, amr_module::ndjhi, amr_module::ndjlo, amr_module::nestlevel, amr_module::node, reclam(), setindices(), amr_module::xperdom, and amr_module::yperdom.

21 
22  use amr_module
23  implicit double precision (a-h, o-z)
24 
25  logical debug/.false./
26  integer ist(3),iend(3),jst(3),jend(3),ishift(3),jshift(3)
27  logical borderx, bordery
28  integer thisbuff
29 
30 c index into alloc from iclo:ichi and jclo:jchi, not 0..leni/j.
31  iadd(i,j) = locm + i - iclo + leni*(j-jclo)
32 
33 c ::::::::::::::::::: basecheck :::::::::::::::::::::::::::
34 c
35 c basecheck - check that potential grid mnew is completely contained
36 c in coarser grids at level 'lbase' (>1) that will
37 c stay fixed during this regridding step
38 c
39 c this version tries to do it without using domflags
40 c slower but better if cant afford memory over entire domain
41 c
42 c mcheck is one bigger since for proper nesting, cell must be
43 c at least one away from boundary of a parent grid, unless
44 c on a domain boundary
45 c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::
46 
47 
48 
49  levnew = node(nestlevel,mnew)
50  borderx = (ilo .eq. 0 .or. ihi .eq. iregsz(levnew)-1)
51  bordery = (jlo .eq. 0 .or. jhi .eq. jregsz(levnew)-1)
52 
53 
54 c if (debug) write(outunit,100) mnew,lbase,ilo,ihi,jlo,jhi,levnew
55 c100 format("NESTCK2 testing grid ",i5," base level ",i5,/,
56 c . " new grid from ilo:hi: ",2i12," to ",2i12," at level ",i4)
57 c
58 c on to initializing for the given grid and its nest checking
59  levratx = 1
60  levraty = 1
61  do 5 lev = lbase, levnew-1
62  levratx = levratx * intratx(lev)
63  levraty = levraty * intraty(lev)
64  5 continue
65 
66 c widen by 1 cell(proper nesting), then project to lbase
67 c this might stick out of domain, fix later
68 c figure out size for scratch storage on base grid for testing
69  iclo = ilo
70  ichi = ihi
71  jclo = jlo
72  jchi = jhi
73  do lev = levnew-1,lbase,-1
74  iclo = iclo/intratx(lev)
75  ichi = ichi/intratx(lev)
76  jclo = jclo/intraty(lev)
77  jchi = jchi/intraty(lev)
78  iclo = iclo - 1
79  ichi = ichi + 1
80  jclo = jclo - 1
81  jchi = jchi + 1
82 c if (debug) then
83 c write(outunit,111) lev, iclo,ichi,jclo,jchi
84 c111 format(10x,"at level",i5," projected coords ilo:hi:",2i10,
85 c . " jlo:hi:",2i10)
86 c endif
87  end do
88 c high end of integer grid index truncates during the divide
89 c if it were exactly lined up with coarser grid it would
90 c not be properly nested, but since we added one to the index
91 c space, we took care of that already.
92 c if (debug) then
93 c write(outunit,108) ilo-1,ihi+1,jlo-1,jhi+1
94 c write(outunit,109) levratx,levraty
95 c108 format(" enlarged (by 1) fine grid from ilo:hi:",2i12,
96 c . " to jlo:hi:", 2i12)
97 c109 format(" refinement factors to base grid of ", 2i12)
98 c write(outunit,101) iclo,ichi,jclo,jchi
99 c101 format("coarsened to lbase, grid from iclo:hi: ",2i12,
100 c . " to jclo:hi:",2i12)
101 c endif
102 
103  if (.not. (xperdom .and. borderx) .and.
104  . .not. (yperdom .and. bordery)) then
105  iclo = max(iclo,0) ! make sure in domain boundary when checking nesting
106  jclo = max(jclo,0)
107  ichi = min(ichi,iregsz(lbase)-1) ! subtract 1 since regsz is number of cells, so -1 is highest index
108  jchi = min(jchi,jregsz(lbase)-1)
109  endif
110 
111 
112  leni = ichi - iclo + 1
113  lenj = jchi - jclo + 1
114  lenrect = leni * lenj
115  locm = igetsp(lenrect)
116  alloc(locm:locm+lenrect-1) = 0.
117 c
118 c if mnew on domain boundary fix flags so ok.
119 c fix extra border, and first/last real edge
120  if (ilo .eq. 0 .and. .not. xperdom) then
121  do j = jclo,jchi
122  alloc(iadd(iclo,j)) = 1.
123  alloc(iadd(iclo+1,j)) = 1.
124  end do
125 
126  endif
127  if (ihi .eq. iregsz(levnew)-1 .and. .not. xperdom) then
128  do j = jclo, jchi
129  alloc(iadd(ichi,j)) = 1.
130  alloc(iadd(ichi-1,j)) = 1.
131  end do
132  endif
133  if (jlo .eq. 0 .and. .not. yperdom) then
134  do i = iclo,ichi
135  alloc(iadd(i,jclo)) = 1.
136  alloc(iadd(i,jclo+1)) = 1.
137  end do
138  endif
139  if (jhi .eq. jregsz(levnew)-1 .and. .not. yperdom) then
140  do i = iclo, ichi
141  alloc(iadd(i,jchi)) = 1.
142  alloc(iadd(i,jchi-1)) = 1.
143  end do
144  endif
145 
146  mptr = lstart(lbase)
147  20 iblo = node(ndilo, mptr) - thisbuff
148  ibhi = node(ndihi, mptr) + thisbuff
149  jblo = node(ndjlo, mptr) - thisbuff
150  jbhi = node(ndjhi, mptr) + thisbuff
151 c
152  ! non periodic case, base level coordinates, just mark if nested.
153  if ((.not. (xperdom .and. borderx)) .and.
154  . .not. (yperdom .and. bordery)) then
155  ixlo = max(iclo,iblo)
156  ixhi = min(ichi,ibhi)
157  jxlo = max(jclo,jblo)
158  jxhi = min(jchi,jbhi)
159  if (.not.((ixlo.le.ixhi) .and. (jxlo.le.jxhi))) go to 30
160  do jx = jxlo, jxhi
161  do ix = ixlo, ixhi
162  alloc(iadd(ix,jx))=1.
163  end do
164  end do
165  go to 30
166  endif
167 c
168 c periodic case: initialize for potential periodicity
169 c each patch divided into 9 regions(some may be empty)
170 c e.g. i from(ilo,-1), (0,iregsz(level)-1),(iregsz(level),ihi)
171 c except using enlarged grid(ilo-1 to ihi+1)
172 c
173  call setindices(ist,iend,jst,jend,iclo,ichi,jclo,jchi,
174  . ishift,jshift,lbase)
175 
176 c compare all regions of coarsened patch with one lbase grid at a time
177  do 25 i = 1, 3
178  i1 = max(iclo,ist(i))
179  i2 = min(ichi, iend(i))
180  do 25 j = 1, 3
181  j1 = max(jclo, jst(j))
182  j2 = min(jchi, jend(j))
183 
184  if (.not. ((i1 .le. i2) .and. (j1 .le. j2))) go to 25
185 c
186 c patch(possibly periodically wrapped) not empty.
187 c see if intersects base grid. wrap coords for periodicity
188  i1_shifted = i1 + ishift(i)
189  i2_shifted = i2 + ishift(i)
190  j1_shifted = j1 + jshift(j)
191  j2_shifted = j2 + jshift(j)
192 
193  ixlo = max(i1_shifted,iblo)
194  ixhi = min(i2_shifted,ibhi)
195  jxlo = max(j1_shifted,jblo)
196  jxhi = min(j2_shifted,jbhi)
197 
198  if (.not.((ixlo.le.ixhi) .and. (jxlo.le.jxhi))) go to 25
199 c mark intersected regions with 1
200  do jx = jxlo, jxhi
201  do ix = ixlo, ixhi
202 c need to mark nesting of orig coords, not coarsened shifted indices
203  ix_unshifted = (ix - ishift(i)) ! back to unshifted coords
204  jx_unshifted = (jx - jshift(j)) ! to mark base grid nesting ok
205  alloc(iadd(ix_unshifted,jx_unshifted)) = 1.
206  end do
207  end do
208 
209  25 continue
210 
211  30 mptr = node(levelptr, mptr)
212  if (mptr .ne. 0) go to 20
213 
214 c output for debugging
215 c if (debug) then
216 c do 34 jj = jclo, jchi
217 c j = jchi + jclo - jj
218 c write(outunit,344)(int(alloc(iadd(i,j))), i=iclo,ichi)
219 c344 format(110i1)
220 c34 continue
221 c endif
222 
223 c
224 c if any zeroes left mnew not nested
225 c
226  do 40 j = jclo, jchi
227  do 40 i = iclo, ichi
228  if (alloc(iadd(i,j)) .eq. 0) then
229  basecheck = .false.
230  go to 99
231  endif
232  40 continue
233 
234 c if made it here then grid is nested
235  basecheck = .true.
236 
237  99 call reclam(locm, lenrect)
238 
239  return
function igetsp(nwords)
Allocate contiguous space of length nword in main storage array alloc.
Definition: igetsp.f:9
subroutine reclam(index, nwords)
Definition: reclam.f:5
integer, dimension(maxlv) iregsz
Definition: amr_module.f90:198
logical function basecheck(mnew, lbase, ilo, ihi, jlo, jhi, nvar, naux, thisBuff)
Check that potential grid mnew is completely contained in coarser grids at level lbase (>1) that will...
Definition: baseCheck.f:21
integer, parameter ndihi
global i index of right border of this grid
Definition: amr_module.f90:111
integer, dimension(maxlv) jregsz
Definition: amr_module.f90:198
integer, dimension(nsize, maxgr) node
Definition: amr_module.f90:198
integer, parameter nestlevel
AMR level of the grid.
Definition: amr_module.f90:44
integer pure function iadd(ivar, i, j)
Definition: intfil.f90:294
subroutine check(nsteps, time, nvar, naux)
Definition: check.f:5
logical yperdom
Definition: amr_module.f90:230
integer, parameter ndilo
global i index of left border of this grid
Definition: amr_module.f90:108
integer, parameter ndjlo
global j index of lower border of this grid
Definition: amr_module.f90:114
integer, dimension(maxlv) lstart
Definition: amr_module.f90:198
integer, dimension(maxlv) intraty
Definition: amr_module.f90:198
integer, parameter outunit
Definition: amr_module.f90:290
subroutine setindices(ist, iend, jst, jend, ilo, ihi, jlo, jhi, ishift, jshift, level)
Definition: setIndices.f:6
integer, parameter ndjhi
global j index of upper border of this grid
Definition: amr_module.f90:117
logical xperdom
Definition: amr_module.f90:230
integer, dimension(maxlv) intratx
Definition: amr_module.f90:198
integer, parameter levelptr
node number (index) of next grid on the same level
Definition: amr_module.f90:35
subroutine domain(nvar, vtime, nx, ny, naux, start_time)
Definition: domain.f:5
The module contains the definition of a "node descriptor" as well as other global variables used duri...
Definition: amr_module.f90:21
real(kind=8), dimension(:), allocatable alloc
Definition: amr_module.f90:218
Here is the call graph for this function: