2D AMRCLAW
prefilp.f90
Go to the documentation of this file.
1 ! :::::::::::::: PREFILRECUR :::::::::::::::::::::::::::::::::::::::::::
16 !
17 ! :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
18 recursive subroutine prefilrecur(level,nvar,valbig,auxbig,naux,time,mitot,mjtot, &
19  nrowst,ncolst,ilo,ihi,jlo,jhi,iglo,ighi,jglo,jghi,patchOnly)
20 
21 
22 
25 
26  implicit none
27 
28  ! Input
29  integer, intent(in) :: level, nvar, naux, mitot, mjtot
30  integer, intent(in) :: ilo,ihi,jlo,jhi,iglo,ighi,jglo,jghi
31  real(kind=8), intent(in) :: time
32  ! false when called from bound, when valbig is whole grid but only filling patch.
33  ! true for recursive coarse sub-patches - grid is patch
34  logical :: patchOnly
35 
36  ! Output
37  real(kind=8), intent(in out) :: valbig(nvar,mitot,mjtot)
38  real(kind=8), intent(in out) :: auxbig(naux,mitot,mjtot)
39 
40  ! Local storage
41  integer :: i, j, ii, jj, ivar, ng, i1, i2, j1, j2, nrowst, ncolst
42  integer :: iputst, jputst, mi, mj, locpatch, locpaux
43  integer :: jbump, iwrap1, iwrap2, jwrap1, tmp, locflip, rect(4)
44  real(kind=8) :: xlwrap, ybwrap
45  integer :: msrc ! this signifies not a real grid, no bndry list with it
46  ! it is possible to preprocess in the periodic case, just more complicated, so postponing
47 
48  integer :: ist(3), iend(3), jst(3), jend(3), ishift(3), jshift(3)
49  real(kind=8) :: scratch(max(mitot,mjtot)*nghost*nvar)
50  real(kind=8) :: scratchaux(max(mitot,mjtot)*nghost*naux)
51 
52  ! dimension at largest possible
53  real(kind=8) :: valPatch((ihi-ilo+1) * (jhi-jlo+1) * nvar)
54  real(kind=8) :: auxPatch((ihi-ilo+1) * (jhi-jlo+1) * naux)
55 
56 
57 ! # will divide patch (from ilo,jlo to ihi,jhi) into 9 possibilities (some empty):
58 ! x sticks out left, x interior, x sticks out right
59 ! same for y. for example, the max. would be
60 ! i from (ilo,-1), (0,iregsz(level)-1), (iregsz(level),ihi)
61 ! # this patch lives in a grid with soln array valbig, which goes from
62 ! (iglo,jglo) to (ighi,jghi).
63 
64  msrc = -1 ! iitialization indicating whether real src grid so can use faster bc list
65 
66  if (xperdom) then
67  ist(1) = ilo
68  ist(2) = 0
69  ist(3) = iregsz(level)
70  iend(1) = -1
71  iend(2) = iregsz(level)-1
72  iend(3) = ihi
73  ishift(1) = iregsz(level)
74  ishift(2) = 0
75  ishift(3) = -iregsz(level)
76  else ! if not periodic, set vals to only have nonnull intersection for interior regoin
77  ist(1) = iregsz(level)
78  ist(2) = ilo
79  ist(3) = iregsz(level)
80  iend(1) = -1
81  iend(2) = ihi
82  iend(3) = -1
83  ishift(1) = 0
84  ishift(2) = 0
85  ishift(3) = 0
86  endif
87 
88  if (yperdom .or. spheredom) then
89  jst(1) = jlo
90  jst(2) = 0
91  jst(3) = jregsz(level)
92  jend(1) = -1
93  jend(2) = jregsz(level)-1
94  jend(3) = jhi
95  jshift(1) = jregsz(level)
96  jshift(2) = 0
97  jshift(3) = -jregsz(level)
98  else
99  jst(1) = jregsz(level)
100  jst(2) = jlo
101  jst(3) = jregsz(level)
102  jend(1) = -1
103  jend(2) = jhi
104  jend(3) = -1
105  jshift(1) = 0
106  jshift(2) = 0
107  jshift(3) = 0
108  endif
109 
110 ! ## loop over the 9 regions (in 2D) of the patch - the interior is i=j=2 plus
111 ! ## the ghost cell regions. If any parts stick out of domain and are periodic
112 ! ## map indices periodically, but stick the values in the correct place
113 ! ## in the orig grid (indicated by iputst,jputst.
114 ! ## if a region sticks out of domain but is not periodic, not handled in (pre)-icall
115 ! ## but in setaux/bcamr (not called from here).
116  do 20 i = 1, 3
117  i1 = max(ilo, ist(i))
118  i2 = min(ihi, iend(i))
119  if (i1 .gt. i2) go to 20
120 
121  do 10 j = 1, 3
122  j1 = max(jlo, jst(j))
123  j2 = min(jhi, jend(j))
124 
125  ! part of patch in this region
126  if (j1 <= j2) then
127  if (.not. spheredom .or. j .eq. 2) then
128  ! make temp patch of just the right size.
129  mi = i2 - i1 + 1
130  mj = j2 - j1 + 1
131  if (mi .gt. (ihi-ilo+1) .or. mj .gt. (jhi-jlo+1)) then
132  write(*,*)" prefilp: not big enough dimension"
133  endif
134  if (naux .gt. 0) &
135  call auxcopyin(auxpatch,mi,mj,auxbig,mitot,mjtot,naux,i1,i2,j1,j2, &
136  iglo,jglo)
137 
138  call filrecur(level,nvar,valpatch,auxpatch,naux,time,mi,mj, &
139  1,1,i1+ishift(i),i2+ishift(i),j1+jshift(j),j2+jshift(j),.true.,msrc)
140  ! copy it back to proper place in valbig
141  call patchcopyout(nvar,valpatch,mi,mj,valbig,mitot,mjtot,i1,i2,j1,j2, &
142  iglo,jglo)
143 
144  else
145 
146  mi = i2 - i1 + 1
147  mj = j2 - j1 + 1
148  ng = 0 ! no ghost cells in this little patch. fill everything.
149 
150  jbump = 0
151  if (j1 < 0) jbump = abs(j1) ! bump up so new bottom is 0
152  if (j2 >= jregsz(level)) jbump = -(j2+1-jregsz(level)) ! bump down
153 
154  ! next 2 lines would take care of periodicity in x
155  iwrap1 = i1 + ishift(i)
156  iwrap2 = i2 + ishift(i)
157  ! next 2 lines take care of mapped sphere bcs
158  iwrap1 = iregsz(level) - iwrap1 -1
159  iwrap2 = iregsz(level) - iwrap2 -1
160  ! swap so that smaller one is left index, etc since mapping reflects
161  tmp = iwrap1
162  iwrap1 = iwrap2
163  iwrap2 = tmp
164 
165  jwrap1 = j1 + jbump
166  xlwrap = xlower + iwrap1*hxposs(level)
167  ybwrap = ylower + jwrap1*hyposs(level)
168 
169  if (naux>0) then
170  scratchaux = needs_to_be_set !flag all cells with signal since dimensioned strangely
171  call setaux(ng,mi,mj,xlwrap,ybwrap,hxposs(level),hyposs(level),naux,scratchaux)
172  endif
173 
174  rect = [iwrap1,iwrap2,j1+jbump,j2+jbump]
175  call filrecur(level,nvar,scratch,scratchaux,naux,time,mi, &
176  mj,1,1,iwrap1,iwrap2,j1+jbump,j2+jbump,.false.,msrc)
177 
178  ! copy back using weird mapping for spherical folding (so cant call copy subr below)
179  do ii = i1, i2
180  do jj = j1, j2
181  ! write(dbugunit,'(" filling loc ",2i5," with ",2i5)') &
182  ! nrowst+ii-fill_indices(1),ncolst+jj-fill_indices(3),mi-(ii-i1),mj-jj+j1
183 
184  do ivar = 1, nvar
185  valbig(ivar,nrowst+(ii-ilo),ncolst+(jj-jlo)) = &
186  scratch(iaddscratch(ivar,mi-(ii-i1),mj-(jj-j1)))
187  end do
188  ! write(dbugunit,'(" new val is ",4e15.7)')(valbig(ivar, &
189  ! nrowst+(ii-fill_indices(1)),ncolst+(jj-fill_indices(3))),ivar=1,nvar)
190  end do
191  end do
192  endif ! end if not spherical or j == 2
193  endif ! end if region not empty
194 
195  10 continue
196  20 continue
197 
198 contains
199 
200  integer pure function iadd(n,i,j)
201  implicit none
202  integer, intent(in) :: n, i, j
203  iadd = locflip + n-1 + nvar*((j-1)*mi+i-1)
204  end function iadd
205 
206  integer pure function iaddscratch(n,i,j)
207  implicit none
208  integer, intent(in) :: n, i, j
209  iaddscratch = n + nvar*((j-1)*mi+i-1) ! no subtract 1
210 
211  end function iaddscratch
212 
213 
214 end subroutine prefilrecur
215 
216 ! ============================================================================================
217 
218 subroutine patchcopyout(nvar,valpatch,mi,mj,valbig,mitot,mjtot,i1,i2,j1,j2,iglo,jglo)
219 
220  ! the patch was filled from a possibly periodically wrapped place.
221  ! put it back where it should go in original grids solution array
222 
223  use amr_module
224  implicit none
225 
226  ! Input
227  integer :: mi, mj, nvar, mitot, mjtot, i1, i2,j1, j2, iglo, ighi, jglo, jghi
228 
229  ! Output
230  real(kind=8), intent(in out) :: valbig(nvar,mitot,mjtot)
231  real(kind=8), intent(in out) :: valpatch(nvar,mi,mj)
232 
233  ! Local storage
234  integer :: ist, jst
235 
236 
237  ! this ghost cell patch subset goes from (i1,j1) to (i2,j2) in integer index space
238  ! the grid (including ghost cells) is from (iglo,jglo) to (ighi,jghi)
239  ! figure out where to copy
240  ist = i1 - iglo + 1 ! offset 1 since soln array is 1-based
241  jst = j1 - jglo + 1
242 
243  valbig(:,ist:ist+mi-1, jst:jst+mj-1) = valpatch
244 
245 end subroutine patchcopyout
246 
247 ! ============================================================================================
248 
249 subroutine auxcopyin(auxPatch,mi,mj,auxbig,mitot,mjtot,naux,i1,i2,j1,j2,iglo,jglo)
251  ! set the aux array for the patch to go with the soln vals to be filled in filpatch,
252  ! by copying from valbig's auxbig array
253 
254  use amr_module
255  implicit none
256 
257  ! Input
258  integer :: mi, mj, naux, mitot, mjtot, i1, i2,j1, j2, iglo, ighi, jglo, jghi
259 
260  ! Output
261  real(kind=8), intent(in out) :: auxbig(naux,mitot,mjtot)
262  real(kind=8), intent(in out) :: auxPatch(naux,mi,mj)
263 
264  ! Local storage
265  integer :: ist, jst
266 
267 
268  ! this ghost cell patch subset goes from (i1,j1) to (i2,j2) in integer index space
269  ! the grid (including ghost cells) is from (iglo,jglo) to (ighi,jghi)
270  ! figure out where to copy
271  ist = i1 - iglo + 1 ! offset 1 since aux arrays are 1-based
272  jst = j1 - jglo + 1
273 
274  auxpatch(:,1:mi,1:mj) = auxbig(:,ist:ist+mi-1, jst:jst+mj-1)
275 
276 end subroutine auxcopyin
subroutine patchcopyout(nvar, valpatch, mi, mj, valbig, mitot, mjtot, i1, i2, j1, j2, iglo, jglo)
Definition: prefilp.f90:219
recursive subroutine prefilrecur(level, nvar, valbig, auxbig, naux, time, mitot, mjtot, nrowst, ncolst, ilo, ihi, jlo, jhi, iglo, ighi, jglo, jghi, patchOnly)
For periodic boundary conditions more work needed to fill the piece of the boundary.
Definition: prefilp.f90:20
integer, dimension(maxlv) iregsz
Definition: amr_module.f90:198
real(kind=8), dimension(maxlv) hyposs
Definition: amr_module.f90:193
real(kind=8), dimension(maxlv) hxposs
Definition: amr_module.f90:193
integer, dimension(maxlv) jregsz
Definition: amr_module.f90:198
integer pure function iaddscratch(n, i, j)
Definition: prefilp.f90:207
real(kind=8) xlower
Definition: amr_module.f90:231
integer pure function iadd(ivar, i, j)
Definition: intfil.f90:294
logical yperdom
Definition: amr_module.f90:230
real(kind=8) ylower
Definition: amr_module.f90:231
real(kind=8), parameter needs_to_be_set
Definition: amr_module.f90:168
logical spheredom
Definition: amr_module.f90:230
recursive subroutine filrecur(level, nvar, valbig, aux, naux, t, mitot, mjtot, nrowst, ncolst, ilo, ihi, jlo, jhi, patchOnly, msrc)
Fill a region (patch) described by:
Definition: filpatch.f90:73
logical xperdom
Definition: amr_module.f90:230
subroutine auxcopyin(auxPatch, mi, mj, auxbig, mitot, mjtot, naux, i1, i2, j1, j2, iglo, jglo)
Definition: prefilp.f90:250
integer nghost
Definition: amr_module.f90:232
The module contains the definition of a "node descriptor" as well as other global variables used duri...
Definition: amr_module.f90:21
subroutine setaux(mbc, mx, my, xlower, ylower, dx, dy, maux, aux)
Definition: setaux.f90:2
real(kind=8), dimension(:), allocatable alloc
Definition: amr_module.f90:218