Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !! Begin GPU remap module !!
3 : !! by Rick Archibald, 2010 !!
4 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5 : module vertremap_mod
6 :
7 : !**************************************************************************************
8 : !
9 : ! Purpose:
10 : ! Construct sub-grid-scale polynomials using piecewise spline method with
11 : ! monotone filters.
12 : !
13 : ! References: PCM - Zerroukat et al., Q.J.R. Meteorol. Soc., 2005. (ZWS2005QJR)
14 : ! PSM - Zerroukat et al., Int. J. Numer. Meth. Fluids, 2005. (ZWS2005IJMF)
15 : !
16 : !**************************************************************************************
17 :
18 : use shr_kind_mod, only: r8=>shr_kind_r8
19 : use dimensions_mod, only: np,nlev,qsize,nlevp,npsq,nc
20 : use hybvcoord_mod, only: hvcoord_t
21 : use element_mod, only: element_t
22 : use fvm_control_volume_mod, only: fvm_struct
23 : use perf_mod, only: t_startf, t_stopf ! _EXTERNAL
24 : use parallel_mod, only: parallel_t
25 : use cam_abortutils, only: endrun
26 :
27 : implicit none
28 :
29 : public remap1 ! remap any field, splines, monotone
30 : public remap1_nofilter ! remap any field, splines, no filter
31 : ! todo: tweak interface to match remap1 above, rename remap1_ppm:
32 : public remap_q_ppm ! remap state%Q, PPM, monotone
33 :
34 : contains
35 :
36 : !=======================================================================================================!
37 :
38 1026000 : subroutine remap1(Qdp,nx,qstart,qstop,qsize,dp1,dp2,ptop,identifier,Qdp_mass,kord)
39 : use fv_mapz, only: map1_ppm
40 : ! remap 1 field
41 : ! input: Qdp field to be remapped (NOTE: MASS, not MIXING RATIO)
42 : ! dp1 layer thickness (source)
43 : ! dp2 layer thickness (target)
44 : !
45 : ! output: remaped Qdp, conserving mass, monotone on Q=Qdp/dp
46 : !
47 : integer, intent(in) :: nx,qstart,qstop,qsize
48 : real (kind=r8), intent(inout) :: Qdp(nx,nx,nlev,qsize)
49 : real (kind=r8), intent(in) :: dp1(nx,nx,nlev),dp2(nx,nx,nlev)
50 : integer, intent(in) :: identifier !0: tracers, 1: T, -1: u,v
51 : real (kind=r8), intent(in) :: ptop
52 : logical, intent(in) :: Qdp_mass
53 : integer, intent(in) :: kord(qsize)
54 : ! ========================
55 : ! Local Variables
56 : ! ========================
57 2052000 : real (kind=r8) :: pe1(nx,nlev+1),pe2(nx,nlev+1),inv_dp(nx,nx,nlev),dp2_local(nx,nlev)
58 2052000 : real (kind=r8) :: tmp(nx,nlev), gz(nx)
59 : integer :: i,j,k,itrac
60 : logical :: logp
61 1026000 : integer :: kord_local(qsize)
62 :
63 11286000 : kord_local = kord
64 :
65 3488400 : if (any(kord(:) >= 0)) then
66 205200 : if (.not.qdp_mass) then
67 8618400 : do itrac=1,qsize
68 8618400 : if (kord(itrac) >= 0) then
69 8690220000 : Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)*dp1(:,:,:)
70 : end if
71 : end do
72 : end if
73 205200 : call remap_Q_ppm(qdp,nx,qstart,qstop,qsize,dp1,dp2,kord)
74 205200 : if (.not.qdp_mass) then
75 8618400 : do itrac=1,qsize
76 8618400 : if (kord(itrac) >= 0) then
77 8690220000 : Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)/dp2(:,:,:)
78 : end if
79 : end do
80 : end if
81 : endif
82 1026000 : if (any(kord(:)<0)) then
83 : !
84 : ! check if remapping over p or log(p)
85 : !
86 : ! can not mix and match here (all kord's must >-20 or <=-20)
87 : !
88 1026000 : if (any(kord(:)>-20)) then
89 11286000 : kord_local = abs(kord)
90 : logp = .false.
91 : else
92 0 : kord_local = abs(kord/10)
93 0 : if (identifier==1) then
94 : logp = .true.
95 : else
96 0 : logp = .false.
97 : end if
98 : end if
99 : !
100 : ! modified FV3 vertical remapping
101 : !
102 1026000 : if (qdp_mass) then
103 801921600 : inv_dp = 1.0_r8/dp1
104 1846800 : do itrac=1,qsize
105 1846800 : if (kord(itrac)<0) then
106 2806725600 : Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)*inv_dp(:,:,:)
107 : end if
108 : end do
109 : end if
110 1026000 : if (logp) then
111 0 : do j=1,nx
112 0 : pe1(:,1) = ptop
113 0 : pe2(:,1) = ptop
114 0 : do k=1,nlev
115 0 : do i=1,nx
116 0 : pe1(i,k+1) = pe1(i,k)+dp1(i,j,k)
117 0 : pe2(i,k+1) = pe2(i,k)+dp2(i,j,k)
118 : end do
119 : end do
120 0 : pe1(:,nlev+1) = pe2(:,nlev+1)
121 0 : do k=1,nlev+1
122 0 : do i=1,nx
123 0 : pe1(i,k) = log(pe1(i,k))
124 0 : pe2(i,k) = log(pe2(i,k))
125 : end do
126 : end do
127 :
128 0 : do itrac=1,qsize
129 0 : if (kord(itrac)<0) then
130 : call map1_ppm( nlev, pe1(:,:), Qdp(:,:,:,itrac), gz, &
131 : nlev, pe2(:,:), Qdp(:,:,:,itrac), &
132 0 : 1, nx, j, 1, nx, 1, nx, identifier, kord_local(itrac))
133 : end if
134 : end do
135 : ! call mapn_tracer(qsize, nlev, pe1, pe2, Qdp, dp2_local, kord, j, &
136 : ! 1, nx, 1, nx, 1, nx, 0.0_r8, fill)
137 : end do
138 : else
139 4924800 : do j=1,nx
140 18878400 : pe1(:,1) = ptop
141 18878400 : pe2(:,1) = ptop
142 366487200 : do k=1,nlev
143 1759590000 : do i=1,nx
144 1393102800 : pe1(i,k+1) = pe1(i,k)+dp1(i,j,k)
145 1755691200 : pe2(i,k+1) = pe2(i,k)+dp2(i,j,k)
146 : end do
147 : end do
148 18878400 : pe1(:,nlev+1) = pe2(:,nlev+1)
149 37551600 : do itrac=1,qsize
150 36525600 : if (kord(itrac)<0) then
151 : call map1_ppm( nlev, pe1(:,:), Qdp(:,:,:,itrac), gz, &!phl
152 : nlev, pe2(:,:), Qdp(:,:,:,itrac), &
153 11080800 : 1, nx, j, 1, nx, 1, nx, identifier, kord_local(itrac))
154 : end if
155 : end do
156 : ! call mapn_tracer(qsize, nlev, pe1, pe2, Qdp, dp2_local, kord, j, &
157 : ! 1, nx, 1, nx, 1, nx, 0.0_r8, fill)
158 : end do
159 : end if
160 1026000 : if (qdp_mass) then
161 1846800 : do itrac=1,qsize
162 1846800 : if (kord(itrac)<0) then
163 2806725600 : Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)*dp2(:,:,:)
164 : end if
165 : end do
166 : end if
167 : end if
168 1026000 : end subroutine remap1
169 :
170 0 : subroutine remap1_nofilter(Qdp,nx,qsize,dp1,dp2)
171 : ! remap 1 field
172 : ! input: Qdp field to be remapped (NOTE: MASS, not MIXING RATIO)
173 : ! dp1 layer thickness (source)
174 : ! dp2 layer thickness (target)
175 : !
176 : ! output: remaped Qdp, conserving mass
177 : !
178 : implicit none
179 : integer, intent(in) :: nx,qsize
180 : real (kind=r8), intent(inout) :: Qdp(nx,nx,nlev,qsize)
181 : real (kind=r8), intent(in) :: dp1(nx,nx,nlev),dp2(nx,nx,nlev)
182 : ! ========================
183 : ! Local Variables
184 : ! ========================
185 :
186 : real (kind=r8), dimension(nlev+1) :: rhs,lower_diag,diag,upper_diag,q_diag,zgam,z1c,z2c,zv
187 : real (kind=r8), dimension(nlev) :: h,Qcol,za0,za1,za2,zarg,zhdp
188 : real (kind=r8) :: tmp_cal,zv1,zv2
189 : integer :: zkr(nlev+1),i,ilev,j,jk,k,q
190 : logical :: abort=.false.
191 : ! call t_startf('remap1_nofilter')
192 :
193 : #if (defined COLUMN_OPENMP)
194 : !$omp parallel do num_threads(tracer_num_threads) &
195 : !$omp private(q,i,j,z1c,z2c,zv,k,Qcol,zkr,ilev) &
196 : !$omp private(jk,zgam,zhdp,h,zarg,rhs,lower_diag,diag,upper_diag,q_diag,tmp_cal) &
197 : !$omp private(za0,za1,za2) &
198 : !$omp private(ip2,zv1,zv2)
199 : #endif
200 0 : do q=1,qsize
201 0 : do i=1,nx
202 0 : do j=1,nx
203 :
204 0 : z1c(1)=0 ! source grid
205 0 : z2c(1)=0 ! target grid
206 0 : do k=1,nlev
207 0 : z1c(k+1)=z1c(k)+dp1(i,j,k)
208 0 : z2c(k+1)=z2c(k)+dp2(i,j,k)
209 : enddo
210 :
211 0 : zv(1)=0
212 0 : do k=1,nlev
213 0 : Qcol(k)=Qdp(i,j,k,q)! *(z1c(k+1)-z1c(k)) input is mass
214 0 : zv(k+1) = zv(k)+Qcol(k)
215 : enddo
216 :
217 0 : if (ABS(z2c(nlev+1)-z1c(nlev+1)) >= 0.000001_r8) then
218 0 : write(6,*) 'SURFACE PRESSURE IMPLIED BY ADVECTION SCHEME'
219 0 : write(6,*) 'NOT CORRESPONDING TO SURFACE PRESSURE IN '
220 0 : write(6,*) 'DATA FOR MODEL LEVELS'
221 0 : write(6,*) 'PLEVMODEL=',z2c(nlev+1)
222 0 : write(6,*) 'PLEV =',z1c(nlev+1)
223 0 : write(6,*) 'DIFF =',z2c(nlev+1)-z1c(nlev+1)
224 0 : abort=.true.
225 : endif
226 :
227 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
228 : !! quadratic splies with UK met office monotonicity constraints !!
229 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
230 :
231 0 : zkr = 99
232 0 : ilev = 2
233 0 : zkr(1) = 1
234 0 : zkr(nlev+1) = nlev
235 0 : kloop: do k = 2,nlev
236 0 : do jk = ilev,nlev+1
237 0 : if (z1c(jk) >= z2c(k)) then
238 0 : ilev = jk
239 0 : zkr(k) = jk-1
240 0 : cycle kloop
241 : endif
242 : enddo
243 : enddo kloop
244 :
245 0 : zgam = (z2c(1:nlev+1)-z1c(zkr)) / (z1c(zkr+1)-z1c(zkr))
246 0 : zgam(1) = 0.0_r8
247 0 : zgam(nlev+1) = 1.0_r8
248 0 : zhdp = z1c(2:nlev+1)-z1c(1:nlev)
249 :
250 :
251 0 : h = 1/zhdp
252 0 : zarg = Qcol * h
253 0 : rhs = 0
254 0 : lower_diag = 0
255 0 : diag = 0
256 0 : upper_diag = 0
257 :
258 0 : rhs(1)=3*zarg(1)
259 0 : rhs(2:nlev) = 3*(zarg(2:nlev)*h(2:nlev) + zarg(1:nlev-1)*h(1:nlev-1))
260 0 : rhs(nlev+1)=3*zarg(nlev)
261 :
262 0 : lower_diag(1)=1
263 0 : lower_diag(2:nlev) = h(1:nlev-1)
264 0 : lower_diag(nlev+1)=1
265 :
266 0 : diag(1)=2
267 0 : diag(2:nlev) = 2*(h(2:nlev) + h(1:nlev-1))
268 0 : diag(nlev+1)=2
269 :
270 0 : upper_diag(1)=1
271 0 : upper_diag(2:nlev) = h(2:nlev)
272 0 : upper_diag(nlev+1)=0
273 :
274 0 : q_diag(1)=-upper_diag(1)/diag(1)
275 0 : rhs(1)= rhs(1)/diag(1)
276 :
277 0 : do k=2,nlev+1
278 0 : tmp_cal = 1/(diag(k)+lower_diag(k)*q_diag(k-1))
279 0 : q_diag(k) = -upper_diag(k)*tmp_cal
280 0 : rhs(k) = (rhs(k)-lower_diag(k)*rhs(k-1))*tmp_cal
281 : enddo
282 0 : do k=nlev,1,-1
283 0 : rhs(k)=rhs(k)+q_diag(k)*rhs(k+1)
284 : enddo
285 :
286 0 : za0 = rhs(1:nlev)
287 0 : za1 = -4*rhs(1:nlev) - 2*rhs(2:nlev+1) + 6*zarg
288 0 : za2 = 3*rhs(1:nlev) + 3*rhs(2:nlev+1) - 6*zarg
289 :
290 :
291 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
292 : !! start iteration from top to bottom of atmosphere !!
293 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
294 :
295 : zv1 = 0
296 0 : do k=1,nlev
297 0 : if (zgam(k+1)>1_r8) then
298 0 : WRITE(*,*) 'r not in [0:1]', zgam(k+1)
299 0 : abort=.true.
300 : endif
301 0 : zv2 = zv(zkr(k+1))+(za0(zkr(k+1))*zgam(k+1)+(za1(zkr(k+1))/2)*(zgam(k+1)**2)+ &
302 0 : (za2(zkr(k+1))/3)*(zgam(k+1)**3))*zhdp(zkr(k+1))
303 0 : Qdp(i,j,k,q) = (zv2 - zv1) ! / (z2c(k+1)-z2c(k) ) dont convert back to mixing ratio
304 0 : zv1 = zv2
305 : enddo
306 : enddo
307 : enddo
308 : enddo ! q loop
309 0 : if (abort) then
310 0 : call endrun('Bad levels in remap1_nofilter. usually CFL violatioin')
311 : end if
312 0 : end subroutine remap1_nofilter
313 :
314 : !=============================================================================!
315 :
316 : !This uses the exact same model and reference grids and data as remap_Q, but it interpolates
317 : !using PPM instead of splines.
318 205200 : subroutine remap_Q_ppm(Qdp,nx,qstart,qstop,qsize,dp1,dp2,kord)
319 : ! remap 1 field
320 : ! input: Qdp field to be remapped (NOTE: MASS, not MIXING RATIO)
321 : ! dp1 layer thickness (source)
322 : ! dp2 layer thickness (target)
323 : !
324 : ! output: remaped Qdp, conserving mass
325 : !
326 : implicit none
327 : integer,intent(in) :: nx,qstart,qstop,qsize
328 : real (kind=r8), intent(inout) :: Qdp(nx,nx,nlev,qsize)
329 : real (kind=r8), intent(in) :: dp1(nx,nx,nlev),dp2(nx,nx,nlev)
330 : integer , intent(in) :: kord(qsize)
331 : ! Local Variables
332 : integer, parameter :: gs = 2 !Number of cells to place in the ghost region
333 : real(kind=r8), dimension( nlev+2 ) :: pio !Pressure at interfaces for old grid
334 : real(kind=r8), dimension( nlev+1 ) :: pin !Pressure at interfaces for new grid
335 : real(kind=r8), dimension( nlev+1 ) :: masso !Accumulate mass up to each interface
336 : real(kind=r8), dimension( 1-gs:nlev+gs) :: ao !Tracer value on old grid
337 : real(kind=r8), dimension( 1-gs:nlev+gs) :: dpo !change in pressure over a cell for old grid
338 : real(kind=r8), dimension( 1-gs:nlev+gs) :: dpn !change in pressure over a cell for old grid
339 : real(kind=r8), dimension(3, nlev ) :: coefs !PPM coefficients within each cell
340 : real(kind=r8), dimension( nlev ) :: z1, z2
341 : real(kind=r8) :: ppmdx(10,0:nlev+1) !grid spacings
342 : real(kind=r8) :: massn1, massn2, ext(2)
343 : integer :: i, j, k, q, kk, kid(nlev)
344 :
345 820800 : do j = 1 , nx
346 2667600 : do i = 1 , nx
347 :
348 1846800 : pin(1)=0
349 1846800 : pio(1)=0
350 173599200 : do k=1,nlev
351 171752400 : dpn(k)=dp2(i,j,k)
352 171752400 : dpo(k)=dp1(i,j,k)
353 171752400 : pin(k+1)=pin(k)+dpn(k)
354 173599200 : pio(k+1)=pio(k)+dpo(k)
355 : enddo
356 :
357 :
358 :
359 1846800 : pio(nlev+2) = pio(nlev+1) + 1._r8 !This is here to allow an entire block of k threads to run in the remapping phase.
360 : !It makes sure there's an old interface value below the domain that is larger.
361 1846800 : pin(nlev+1) = pio(nlev+1) !The total mass in a column does not change.
362 : !Therefore, the pressure of that mass cannot either.
363 : !Fill in the ghost regions with mirrored values. if vert_remap_q_alg is defined, this is of no consequence.
364 5540400 : do k = 1 , gs
365 3693600 : dpo(1 -k) = dpo( k)
366 5540400 : dpo(nlev+k) = dpo(nlev+1-k)
367 : enddo
368 :
369 : !Compute remapping intervals once for all tracers. Find the old grid cell index in which the
370 : !k-th new cell interface resides. Then integrate from the bottom of that old cell to the new
371 : !interface location. In practice, the grid never deforms past one cell, so the search can be
372 : !simplified by this. Also, the interval of integration is usually of magnitude close to zero
373 : !or close to dpo because of minimial deformation.
374 : !Numerous tests confirmed that the bottom and top of the grids match to machine precision, so
375 : !I set them equal to each other.
376 173599200 : do k = 1 , nlev
377 171752400 : kk = k !Keep from an order n^2 search operation by assuming the old cell index is close.
378 : !Find the index of the old grid cell in which this new cell's bottom interface resides.
379 : ! do while ( pio(kk) <= pin(k+1) )
380 : ! kk = kk + 1
381 : ! if(kk==nlev+2) exit
382 : ! enddo
383 : ! kk = kk - 1 !kk is now the cell index we're integrating over.
384 :
385 171752400 : if (pio(kk) <= pin(k+1)) then
386 424081729 : do while ( pio(kk) <= pin(k+1) )
387 252329329 : kk = kk + 1
388 : enddo
389 171752400 : kk = kk - 1 !kk is now the cell index we're integrating over.
390 : else
391 : call binary_search(pio, pin(k+1), kk)
392 : end if
393 171752400 : if (kk == nlev+1) kk = nlev !This is to keep the indices in bounds.
394 : !Top bounds match anyway, so doesn't matter what coefficients are used
395 171752400 : kid(k) = kk !Save for reuse
396 171752400 : z1(k) = -0.5_R8 !This remapping assumes we're starting from the left interface of an old grid cell
397 : !In fact, we're usually integrating very little or almost all of the cell in question
398 173599200 : z2(k) = ( pin(k+1) - ( pio(kk) + pio(kk+1) ) * 0.5_r8 ) / dpo(kk) !PPM interpolants are normalized to an independent
399 : !coordinate domain [-0.5,0.5].
400 : enddo
401 :
402 : !This turned out a big optimization, remembering that only parts of the PPM algorithm depends on the data, namely the
403 : !limiting. So anything that depends only on the grid is pre-computed outside the tracer loop.
404 1846800 : ppmdx(:,:) = compute_ppm_grids( dpo)
405 :
406 : !From here, we loop over tracers for only those portions which depend on tracer data, which includes PPM limiting and
407 : !mass accumulation
408 78181200 : do q = qstart, qstop
409 77565600 : if (kord(q) >= 0) then
410 : !Accumulate the old mass up to old grid cell interface locations to simplify integration
411 : !during remapping. Also, divide out the grid spacing so we're working with actual tracer
412 : !values and can conserve mass. The option for ifndef ZEROHORZ I believe is there to ensure
413 : !tracer consistency for an initially uniform field. I copied it from the old remap routine.
414 64638000 : masso(1) = 0._r8
415 :
416 6075972000 : do k = 1 , nlev
417 6011334000 : ao(k) = Qdp(i,j,k,q)
418 6011334000 : masso(k+1) = masso(k) + ao(k) !Accumulate the old mass. This will simplify the remapping
419 6075972000 : ao(k) = ao(k) / dpo(k) !Divide out the old grid spacing because we want the tracer mixing ratio, not mass.
420 : enddo
421 : !Fill in ghost values. Ignored if kord == 2
422 64638000 : if (kord(q) == 10) then
423 6140610000 : ext(1) = minval(ao(1:nlev))
424 6140610000 : ext(2) = maxval(ao(1:nlev))
425 64638000 : call linextrap(dpo(2), dpo(1), dpo(0), dpo(-1), ao(2), ao(1), ao(0), ao(-1), ext(1), ext(2))
426 : call linextrap(dpo(nlev-1), dpo(nlev), dpo(nlev+1), dpo(nlev+2), &
427 64638000 : ao(nlev-1), ao(nlev), ao(nlev+1), ao(nlev+2), ext(1), ext(2))
428 : else
429 0 : do k = 1 , gs
430 0 : ao(1 -k) = ao( k)
431 0 : ao(nlev+k) = ao(nlev+1-k)
432 : enddo
433 : end if
434 : !Compute monotonic and conservative PPM reconstruction over every cell
435 64638000 : coefs(:,:) = compute_ppm( ao , ppmdx, kord(q) )
436 : !Compute tracer values on the new grid by integrating from the old cell bottom to the new
437 : !cell interface to form a new grid mass accumulation. Taking the difference between
438 : !accumulation at successive interfaces gives the mass inside each cell. Since Qdp is
439 : !supposed to hold the full mass this needs no normalization.
440 64638000 : massn1 = 0._r8
441 6075972000 : do k = 1 , nlev
442 6011334000 : kk = kid(k)
443 6011334000 : massn2 = masso(kk) + integrate_parabola( coefs(:,kk) , z1(k) , z2(k) ) * dpo(kk)
444 6011334000 : Qdp(i,j,k,q) = massn2 - massn1
445 6075972000 : massn1 = massn2
446 : enddo
447 : end if
448 : enddo
449 : enddo
450 : enddo
451 : ! call t_stopf('remap_Q_ppm')
452 205200 : end subroutine remap_Q_ppm
453 :
454 : ! Find k such that pio(k) <= pivot < pio(k+1). Provide a reasonable input
455 : ! value for k.
456 0 : subroutine binary_search(pio, pivot, k)
457 : real(kind=r8), intent(in) :: pio(nlev+2), pivot
458 : integer, intent(inout) :: k
459 : integer :: lo, hi, mid
460 :
461 0 : if (pio(k) > pivot) then
462 : lo = 1
463 : hi = k
464 : else
465 0 : lo = k
466 0 : hi = nlev+2
467 : end if
468 0 : do while (hi > lo + 1)
469 0 : k = (lo + hi)/2
470 0 : if (pio(k) > pivot) then
471 : hi = k
472 : else
473 0 : lo = k
474 : end if
475 : end do
476 0 : k = lo
477 0 : end subroutine binary_search
478 : !=======================================================================================================!
479 :
480 : !This compute grid-based coefficients from Collela & Woodward 1984.
481 1846800 : function compute_ppm_grids( dx ) result(rslt)
482 : implicit none
483 : real(kind=r8), intent(in) :: dx(-1:nlev+2) !grid spacings
484 : real(kind=r8) :: rslt(10,0:nlev+1) !grid spacings
485 : integer :: j
486 :
487 : !Calculate grid-based coefficients for stage 1 of compute_ppm
488 177292800 : do j = 0 , nlev+1
489 175446000 : rslt( 1,j) = dx(j) / ( dx(j-1) + dx(j) + dx(j+1) )
490 175446000 : rslt( 2,j) = ( 2._r8*dx(j-1) + dx(j) ) / ( dx(j+1) + dx(j) )
491 177292800 : rslt( 3,j) = ( dx(j) + 2._r8*dx(j+1) ) / ( dx(j-1) + dx(j) )
492 : enddo
493 :
494 : !Caculate grid-based coefficients for stage 2 of compute_ppm
495 175446000 : do j = 0 , nlev
496 173599200 : rslt( 4,j) = dx(j) / ( dx(j) + dx(j+1) )
497 1041595200 : rslt( 5,j) = 1._r8 / sum( dx(j-1:j+2) )
498 173599200 : rslt( 6,j) = ( 2._r8 * dx(j+1) * dx(j) ) / ( dx(j) + dx(j+1 ) )
499 173599200 : rslt( 7,j) = ( dx(j-1) + dx(j ) ) / ( 2._r8 * dx(j ) + dx(j+1) )
500 173599200 : rslt( 8,j) = ( dx(j+2) + dx(j+1) ) / ( 2._r8 * dx(j+1) + dx(j ) )
501 173599200 : rslt( 9,j) = dx(j ) * ( dx(j-1) + dx(j ) ) / ( 2._r8*dx(j ) + dx(j+1) )
502 175446000 : rslt(10,j) = dx(j+1) * ( dx(j+1) + dx(j+2) ) / ( dx(j ) + 2._r8*dx(j+1) )
503 : enddo
504 1846800 : end function compute_ppm_grids
505 :
506 :
507 : !=======================================================================================================!
508 :
509 :
510 :
511 : !This computes a limited parabolic interpolant using a net 5-cell stencil, but the stages of computation are broken up into 3 stages
512 64638000 : function compute_ppm( a , dx , kord) result(coefs)
513 : implicit none
514 : real(kind=r8), intent(in) :: a ( -1:nlev+2) !Cell-mean values
515 : real(kind=r8), intent(in) :: dx (10, 0:nlev+1) !grid spacings
516 : integer, intent(in) :: kord
517 : real(kind=r8) :: coefs(0:2, nlev ) !PPM coefficients (for parabola)
518 : real(kind=r8) :: ai (0:nlev ) !fourth-order accurate, then limited interface values
519 : real(kind=r8) :: dma(0:nlev+1) !An expression from Collela's '84 publication
520 : real(kind=r8) :: da !Ditto
521 : ! Hold expressions based on the grid (which are cumbersome).
522 : real(kind=r8) :: al, ar !Left and right interface values for cell-local limiting
523 : integer :: j
524 : integer :: indB, indE
525 :
526 : ! Stage 1: Compute dma for each cell, allowing a 1-cell ghost stencil below and above the domain
527 6205248000 : do j = 0 , nlev+1
528 6140610000 : da = dx(1,j) * ( dx(2,j) * ( a(j+1) - a(j) ) + dx(3,j) * ( a(j) - a(j-1) ) )
529 30703050000 : dma(j) = minval( (/ abs(da) , 2._r8 * abs( a(j) - a(j-1) ) , 2._r8 * abs( a(j+1) - a(j) ) /) ) * sign(1._r8,da)
530 6205248000 : if ( ( a(j+1) - a(j) ) * ( a(j) - a(j-1) ) <= 0._r8 ) dma(j) = 0._r8
531 : enddo
532 :
533 : ! Stage 2: Compute ai for each cell interface in the physical domain (dimension nlev+1)
534 6140610000 : do j = 0 , nlev
535 12151944000 : ai(j) = a(j) + dx(4,j) * ( a(j+1) - a(j) ) + dx(5,j) * ( dx(6,j) * ( dx(7,j) - dx(8,j) ) &
536 18292554000 : * ( a(j+1) - a(j) ) - dx(9,j) * dma(j+1) + dx(10,j) * dma(j) )
537 : enddo
538 :
539 : ! Stage 3: Compute limited PPM interpolant over each cell in the physical domain
540 : ! (dimension nlev) using ai on either side and ao within the cell.
541 6075972000 : do j = 1 , nlev
542 6011334000 : al = ai(j-1)
543 6011334000 : ar = ai(j )
544 6011334000 : if ( (ar - a(j)) * (a(j) - al) <= 0._r8 ) then
545 1136727753 : al = a(j)
546 1136727753 : ar = a(j)
547 : endif
548 6011334000 : if ( (ar - al) * (a(j) - (al + ar)/2._r8) > (ar - al)**2/6._r8 ) al = 3._r8*a(j) - 2._r8 * ar
549 6011334000 : if ( (ar - al) * (a(j) - (al + ar)/2._r8) < -(ar - al)**2/6._r8 ) ar = 3._r8*a(j) - 2._r8 * al
550 : !Computed these coefficients from the edge values and cell mean in Maple. Assumes normalized coordinates: xi=(x-x0)/dx
551 6011334000 : coefs(0,j) = 1.5_r8 * a(j) - ( al + ar ) / 4._r8
552 6011334000 : coefs(1,j) = ar - al
553 6075972000 : coefs(2,j) = 3._r8 * (-2._r8 * a(j) + ( al + ar ))
554 : enddo
555 :
556 : !If kord == 2, use piecewise constant in the boundaries, and don't use ghost cells.
557 64638000 : if (kord == 2) then
558 0 : coefs(0,1:2) = a(1:2)
559 0 : coefs(1:2,1:2) = 0._r8
560 0 : coefs(0,nlev-1:nlev) = a(nlev-1:nlev)
561 0 : coefs(1:2,nlev-1:nlev) = 0._r8
562 : endif
563 64638000 : end function compute_ppm
564 :
565 :
566 : !=======================================================================================================!
567 :
568 :
569 : !Simple function computes the definite integral of a parabola in normalized coordinates, xi=(x-x0)/dx,
570 : !given two bounds. Make sure this gets inlined during compilation.
571 6011334000 : function integrate_parabola( a , x1 , x2 ) result(mass)
572 : implicit none
573 : real(kind=r8), intent(in) :: a(0:2) !Coefficients of the parabola
574 : real(kind=r8), intent(in) :: x1 !lower domain bound for integration
575 : real(kind=r8), intent(in) :: x2 !upper domain bound for integration
576 : real(kind=r8) :: mass
577 6011334000 : mass = a(0) * (x2 - x1) + a(1) * (x2 ** 2 - x1 ** 2) / 0.2D1 + a(2) * (x2 ** 3 - x1 ** 3) / 0.3D1
578 6011334000 : end function integrate_parabola
579 :
580 :
581 : !=============================================================================================!
582 129276000 : subroutine linextrap(dx1,dx2,dx3,dx4,y1,y2,y3,y4,lo,hi)
583 : real(kind=r8), intent(in) :: dx1,dx2,dx3,dx4,y1,y2,lo,hi
584 : real(kind=r8), intent(out) :: y3,y4
585 :
586 : real(kind=r8), parameter :: half = 0.5_r8
587 :
588 : real(kind=r8) :: x1,x2,x3,x4,a
589 :
590 129276000 : x1 = half*dx1
591 129276000 : x2 = x1 + half*(dx1 + dx2)
592 129276000 : x3 = x2 + half*(dx2 + dx3)
593 129276000 : x4 = x3 + half*(dx3 + dx4)
594 129276000 : a = (x3-x1)/(x2-x1)
595 129276000 : y3 = (1.0_r8-a)*y1 + a*y2
596 129276000 : a = (x4-x1)/(x2-x1)
597 129276000 : y4 = (1.0_r8-a)*y1 + a*y2
598 129276000 : y3 = max(lo, min(hi, y3))
599 129276000 : y4 = max(lo, min(hi, y4))
600 129276000 : end subroutine linextrap
601 : end module vertremap_mod
602 :
603 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
604 : !! End GPU remap module !!
605 : !! by Rick Archibald, 2010 !!
606 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|