91
92
95
97# ifdef DISTRIBUTE
99# endif
101
102
103
104 integer, intent(in) :: ng, tile
105 integer, intent(in) :: LBi, UBi, LBj, UBj
106 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
107 integer, intent(in) :: nstp, nnew
108
109# ifdef ASSUMED_SHAPE
110# ifdef MASKING
111 real(r8), intent(in) :: umask(LBi:,LBj:)
112 real(r8), intent(in) :: vmask(LBi:,LBj:)
113# endif
114 real(r8), intent(in) :: Huon(LBi:,LBj:,:)
115 real(r8), intent(in) :: Hvom(LBi:,LBj:,:)
116 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
117 real(r8), intent(in) :: pm(LBi:,LBj:)
118 real(r8), intent(in) :: pn(LBi:,LBj:)
119 real(r8), intent(in) :: W(LBi:,LBj:,0:)
120# ifdef WEC_VF
121 real(r8), intent(in) :: W_stokes(LBi:,LBj:,0:)
122# endif
123 real(r8), intent(inout) :: gls(LBi:,LBj:,0:,:)
124 real(r8), intent(inout) :: tke(LBi:,LBj:,0:,:)
125# else
126# ifdef MASKING
127 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
128 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
129# endif
130 real(r8), intent(in) :: Huon(LBi:UBi,LBj:UBj,N(ng))
131 real(r8), intent(in) :: Hvom(LBi:UBi,LBj:UBj,N(ng))
132 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
133 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
134 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
135 real(r8), intent(in) :: W(LBi:UBi,LBj:UBj,0:N(ng))
136# ifdef WEC_VF
137 real(r8), intent(in) :: W_stokes(LBi:UBi,LBj:UBj,0:N(ng))
138# endif
139 real(r8), intent(inout) :: gls(LBi:UBi,LBj:UBj,0:N(ng),3)
140 real(r8), intent(inout) :: tke(LBi:UBi,LBj:UBj,0:N(ng),3)
141# endif
142
143
144
145 integer :: i, indx, j, k
146
147 real(r8), parameter :: Gamma = 1.0_r8/6.0_r8
148
149 real(r8) :: cff, cff1, cff2, cff3, cff4
150
151 real(r8), dimension(IminS:ImaxS,N(ng)) :: CF
152 real(r8), dimension(IminS:ImaxS,N(ng)) :: FC
153 real(r8), dimension(IminS:ImaxS,N(ng)) :: FCL
154
155 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,N(ng)) :: Hz_half
156
157 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: EF
158 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FE
159 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FEL
160 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FX
161 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FXL
162 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: XF
163 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
164 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gradL
165
166# include "set_bounds.h"
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
192# ifdef K_C2ADVECTION
193
194
195
196 DO j=jstr,jend
197 DO i=istr,iend+1
198 xf(i,j)=0.5_r8*(huon(i,j,k)+huon(i,j,k+1))
199 fx(i,j)=xf(i,j)* &
200 & 0.5_r8*(tke(i,j,k,nstp)+tke(i-1,j,k,nstp))
201 fxl(i,j)=xf(i,j)* &
202 & 0.5_r8*(gls(i,j,k,nstp)+gls(i-1,j,k,nstp))
203 END DO
204 END DO
205 DO j=jstr,jend+1
206 DO i=istr,iend
207 ef(i,j)=0.5*(hvom(i,j,k)+hvom(i,j,k+1))
208 fe(i,j)=ef(i,j)* &
209 & 0.5*(tke(i,j,k,nstp)+tke(i,j-1,k,nstp))
210 fel(i,j)=ef(i,j)* &
211 & 0.5*(gls(i,j,k,nstp)+gls(i,j-1,k,nstp))
212 END DO
213 END DO
214# else
215
216
217
218 DO j=jstr,jend
219 DO i=istrm1,iendp2
220 grad(i,j)=(tke(i,j,k,nstp)-tke(i-1,j,k,nstp))
221# ifdef MASKING
222 grad(i,j)=grad(i,j)*umask(i,j)
223# endif
224 gradl(i,j)=(gls(i,j,k,nstp)-gls(i-1,j,k,nstp))
225# ifdef MASKING
226 gradl(i,j)=gradl(i,j)*umask(i,j)
227# endif
228 END DO
229 END DO
231 IF (
domain(ng)%Western_Edge(tile))
THEN
232 DO j=jstr,jend
233 grad(istr-1,j)=grad(istr,j)
234 gradl(istr-1,j)=gradl(istr,j)
235 END DO
236 END IF
237 END IF
239 IF (
domain(ng)%Eastern_Edge(tile))
THEN
240 DO j=jstr,jend
241 grad(iend+2,j)=grad(iend+1,j)
242 gradl(iend+2,j)=gradl(iend+1,j)
243 END DO
244 END IF
245 END IF
246 cff=1.0_r8/6.0_r8
247 DO j=jstr,jend
248 DO i=istr,iend+1
249 xf(i,j)=0.5_r8*(huon(i,j,k)+huon(i,j,k+1))
250 fx(i,j)=xf(i,j)* &
251 & 0.5_r8*(tke(i-1,j,k,nstp)+tke(i,j,k,nstp)- &
252 & cff*(grad(i+1,j)-grad(i-1,j)))
253 fxl(i,j)=xf(i,j)* &
254 & 0.5_r8*(gls(i-1,j,k,nstp)+gls(i,j,k,nstp)- &
255 & cff*(gradl(i+1,j)-gradl(i-1,j)))
256 END DO
257 END DO
258
259 DO j=jstrm1,jendp2
260 DO i=istr,iend
261 grad(i,j)=(tke(i,j,k,nstp)-tke(i,j-1,k,nstp))
262# ifdef MASKING
263 grad(i,j)=grad(i,j)*vmask(i,j)
264# endif
265 gradl(i,j)=(gls(i,j,k,nstp)-gls(i,j-1,k,nstp))
266# ifdef MASKING
267 gradl(i,j)=gradl(i,j)*vmask(i,j)
268# endif
269 END DO
270 END DO
272 IF (
domain(ng)%Southern_Edge(tile))
THEN
273 DO i=istr,iend
274 grad(i,jstr-1)=grad(i,jstr)
275 gradl(i,jstr-1)=gradl(i,jstr)
276 END DO
277 END IF
278 END IF
280 IF (
domain(ng)%Northern_Edge(tile))
THEN
281 DO i=istr,iend
282 grad(i,jend+2)=grad(i,jend+1)
283 gradl(i,jend+2)=gradl(i,jend+1)
284 END DO
285 END IF
286 END IF
287 cff=1.0_r8/6.0_r8
288 DO j=jstr,jend+1
289 DO i=istr,iend
290 ef(i,j)=0.5_r8*(hvom(i,j,k)+hvom(i,j,k+1))
291 fe(i,j)=ef(i,j)* &
292 & 0.5_r8*(tke(i,j-1,k,nstp)+tke(i,j,k,nstp)- &
293 & cff*(grad(i,j+1)-grad(i,j-1)))
294 fel(i,j)=ef(i,j)* &
295 & 0.5_r8*(gls(i,j-1,k,nstp)+gls(i,j,k,nstp)- &
296 & cff*(gradl(i,j+1)-gradl(i,j-1)))
297 END DO
298 END DO
299# endif
300
301
302
304 cff1=1.0_r8
305 cff2=0.0_r8
307 indx=nstp
308 ELSE
309 cff1=0.5_r8+gamma
310 cff2=0.5_r8-gamma
311 cff3=(1.0_r8-gamma)*
dt(ng)
312 indx=3-nstp
313 END IF
314 DO j=jstr,jend
315 DO i=istr,iend
316 cff=0.5_r8*(hz(i,j,k)+hz(i,j,k+1))
317 cff4=cff3*pm(i,j)*pn(i,j)
318 hz_half(i,j,k)=cff-cff4*(xf(i+1,j)-xf(i,j)+ &
319 & ef(i,j+1)-ef(i,j))
320 tke(i,j,k,3)=cff*(cff1*tke(i,j,k,nstp)+ &
321 & cff2*tke(i,j,k,indx))- &
322 & cff4*(fx(i+1,j)-fx(i,j)+ &
323 & fe(i,j+1)-fe(i,j))
324 gls(i,j,k,3)=cff*(cff1*gls(i,j,k,nstp)+ &
325 & cff2*gls(i,j,k,indx))- &
326 & cff4*(fxl(i+1,j)-fxl(i,j)+ &
327 & fel(i,j+1)-fel(i,j))
328 tke(i,j,k,nnew)=cff*tke(i,j,k,nstp)
329 gls(i,j,k,nnew)=cff*gls(i,j,k,nstp)
330 END DO
331 END DO
332 END DO
333
334
335
336 DO j=jstr,jend
337# ifdef K_C2ADVECTION
339 DO i=istr,iend
340 cf(i,k)=0.5_r8*(w(i,j,k)+w(i,j,k-1))
341# ifdef WEC_VF
342 cf(i,k)=cf(i,k)+0.5_r8*(w_stokes(i,j,k)+w_stokes(i,j,k-1))
343# endif
344 fc(i,k)=cf(i,k)* &
345 & 0.5_r8*(tke(i,j,k-1,nstp)+tke(i,j,k,nstp))
346 fcl(i,k)=cf(i,k)* &
347 & 0.5_r8*(gls(i,j,k-1,nstp)+gls(i,j,k,nstp))
348 END DO
349 END DO
350# else
351 cff1=7.0_r8/12.0_r8
352 cff2=1.0_r8/12.0_r8
354 DO i=istr,iend
355 cf(i,k)=0.5_r8*(w(i,j,k)+w(i,j,k-1))
356# ifdef WEC_VF
357 cf(i,k)=cf(i,k)+0.5_r8*(w_stokes(i,j,k)+w_stokes(i,j,k-1))
358# endif
359 fc(i,k)=cf(i,k)*(cff1*(tke(i,j,k-1,nstp)+ &
360 & tke(i,j,k ,nstp))- &
361 & cff2*(tke(i,j,k-2,nstp)+ &
362 & tke(i,j,k+1,nstp)))
363 fcl(i,k)=cf(i,k)*(cff1*(gls(i,j,k-1,nstp)+ &
364 & gls(i,j,k ,nstp))- &
365 & cff2*(gls(i,j,k-2,nstp)+ &
366 & gls(i,j,k+1,nstp)))
367 END DO
368 END DO
369 cff1=1.0_r8/3.0_r8
370 cff2=5.0_r8/6.0_r8
371 cff3=1.0_r8/6.0_r8
372 DO i=istr,iend
373 cf(i,1)=0.5*(w(i,j,0)+w(i,j,1))
374# ifdef WEC_VF
375 cf(i,1)=cf(i,1)+0.5_r8*(w_stokes(i,j,0)+w_stokes(i,j,1))
376# endif
377 fc(i,1)=cf(i,1)*(cff1*tke(i,j,0,nstp)+ &
378 & cff2*tke(i,j,1,nstp)- &
379 & cff3*tke(i,j,2,nstp))
380 fcl(i,1)=cf(i,1)*(cff1*gls(i,j,0,nstp)+ &
381 & cff2*gls(i,j,1,nstp)- &
382 & cff3*gls(i,j,2,nstp))
383 cf(i,
n(ng))=0.5*(w(i,j,
n(ng))+w(i,j,
n(ng)-1))
384# ifdef WEC_VF
385 cf(i,
n(ng))=cf(i,
n(ng))+0.5_r8* &
386 & (w_stokes(i,j,
n(ng))+w_stokes(i,j,
n(ng)-1))
387# endif
388 fc(i,
n(ng))=cf(i,
n(ng))*(cff1*tke(i,j,
n(ng) ,nstp)+ &
389 & cff2*tke(i,j,
n(ng)-1,nstp)- &
390 & cff3*tke(i,j,
n(ng)-2,nstp))
391 fcl(i,
n(ng))=cf(i,
n(ng))*(cff1*gls(i,j,
n(ng) ,nstp)+ &
392 & cff2*gls(i,j,
n(ng)-1,nstp)- &
393 & cff3*gls(i,j,
n(ng)-2,nstp))
394 END DO
395# endif
396
397
398
401 ELSE
402 cff3=(1.0_r8-gamma)*
dt(ng)
403 END IF
405 DO i=istr,iend
406 cff4=cff3*pm(i,j)*pn(i,j)
407 hz_half(i,j,k)=hz_half(i,j,k)-cff4*(cf(i,k+1)-cf(i,k))
408 cff1=1.0_r8/hz_half(i,j,k)
409 tke(i,j,k,3)=cff1*(tke(i,j,k,3)- &
410 & cff4*(fc(i,k+1)-fc(i,k)))
411 gls(i,j,k,3)=cff1*(gls(i,j,k,3)- &
412 & cff4*(fcl(i,k+1)-fcl(i,k)))
413 END DO
414 END DO
415 END DO
416
417
418
420 & lbi, ubi, lbj, ubj,
n(ng), &
421 & imins, imaxs, jmins, jmaxs, &
422 & 3, nstp, &
423 & gls, tke)
424
427 & lbi, ubi, lbj, ubj, 0,
n(ng), &
428 & tke(:,:,:,3))
430 & lbi, ubi, lbj, ubj, 0,
n(ng), &
431 & gls(:,:,:,3))
432 END IF
433
434# ifdef DISTRIBUTE
436 & lbi, ubi, lbj, ubj, 0,
n(ng), &
439 & tke(:,:,:,3), &
440 & gls(:,:,:,3))
441# endif
442
443 RETURN
subroutine exchange_w3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
integer, dimension(:), allocatable n
type(t_domain), dimension(:), allocatable domain
integer, dimension(:), allocatable iic
real(dp), dimension(:), allocatable dt
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
logical, dimension(:,:), allocatable compositegrid
integer, parameter isouth
integer, dimension(:), allocatable ntfirst
integer, parameter inorth
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
subroutine, public tkebc_tile(ng, tile, lbi, ubi, lbj, ubj, ubk, imins, imaxs, jmins, jmaxs, nout, nstp, gls, tke)