108
109
113
115# ifdef DISTRIBUTE
117# endif
119
120
121
122 integer, intent(in) :: ng, tile
123 integer, intent(in) :: LBi, UBi, LBj, UBj
124 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
125 integer, intent(in) :: nstp, nnew
126
127# ifdef ASSUMED_SHAPE
128# ifdef MASKING
129 real(r8), intent(in) :: umask(LBi:,LBj:)
130 real(r8), intent(in) :: vmask(LBi:,LBj:)
131# endif
132 real(r8), intent(in) :: Huon(LBi:,LBj:,:)
133 real(r8), intent(in) :: Hvom(LBi:,LBj:,:)
134 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
135 real(r8), intent(in) :: pm(LBi:,LBj:)
136 real(r8), intent(in) :: pn(LBi:,LBj:)
137 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
138 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
139 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
140 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
141 real(r8), intent(in) :: W(LBi:,LBj:,0:)
142 real(r8), intent(in) :: bustr(LBi:,LBj:)
143 real(r8), intent(in) :: bvstr(LBi:,LBj:)
144 real(r8), intent(in) :: sustr(LBi:,LBj:)
145 real(r8), intent(in) :: svstr(LBi:,LBj:)
146 real(r8), intent(in) :: bvf(LBi:,LBj:,0:)
147
148 real(r8), intent(inout) :: Akt(LBi:,LBj:,0:,:)
149 real(r8), intent(inout) :: Akv(LBi:,LBj:,0:)
150 real(r8), intent(inout) :: Akk(LBi:,LBj:,0:)
151 real(r8), intent(inout) :: Lscale(LBi:,LBj:,0:)
152 real(r8), intent(inout) :: gls(LBi:,LBj:,0:,:)
153 real(r8), intent(inout) :: tke(LBi:,LBj:,0:,:)
154# else
155# ifdef MASKING
156 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
157 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
158# endif
159 real(r8), intent(in) :: Huon(LBi:UBi,LBj:UBj,N(ng))
160 real(r8), intent(in) :: Hvom(LBi:UBi,LBj:UBj,N(ng))
161 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
162 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
163 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
164 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
165 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
166 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
167 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
168 real(r8), intent(in) :: W(LBi:UBi,LBj:UBj,0:N(ng))
169 real(r8), intent(in) :: bustr(LBi:UBi,LBj:UBj)
170 real(r8), intent(in) :: bvstr(LBi:UBi,LBj:UBj)
171 real(r8), intent(in) :: sustr(LBi:UBi,LBj:UBj)
172 real(r8), intent(in) :: svstr(LBi:UBi,LBj:UBj)
173 real(r8), intent(in) :: bvf(LBi:UBi,LBj:UBj,0:N(ng))
174
175 real(r8), intent(inout) :: Akt(LBi:UBi,LBj:UBj,0:N(ng),NAT)
176 real(r8), intent(inout) :: Akv(LBi:UBi,LBj:UBj,0:N(ng))
177 real(r8), intent(inout) :: Akk(LBi:UBi,LBj:UBj,0:N(ng))
178 real(r8), intent(inout) :: Lscale(LBi:UBi,LBj:UBj,0:N(ng))
179 real(r8), intent(inout) :: gls(LBi:UBi,LBj:UBj,0:N(ng),3)
180 real(r8), intent(inout) :: tke(LBi:UBi,LBj:UBj,0:N(ng),3)
181# endif
182
183
184
185 integer :: i, itrc, j, k
186
187 real(r8), parameter :: Gadv = 1.0_r8/3.0_r8
188 real(r8), parameter :: eps = 1.0e-10_r8
189
190 real(r8) :: Gh, Ls_unlmt, Ls_lmt, Qprod, Qdiss, Sh, Sm, Wscale
191 real(r8) :: cff, cff1, cff2, cff3, ql, strat2
192
193 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: BCK
194 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: BCP
195 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
196 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCK
197 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCP
198 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: dU
199 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: dV
200
201 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,0:N(ng)) :: shear2
202 real(r8), dimension(IminS:ImaxS,JminS:JmaxS,0:N(ng)) :: buoy2
203
204 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FEK
205 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FEP
206 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FXK
207 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FXP
208 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: curvK
209 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: curvP
210 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gradK
211 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gradP
212
213# include "set_bounds.h"
214
215
216
217
218
219# ifdef RI_SPLINES
220 DO j=jstrm1,jendp1
221 DO i=istrm1,iendp1
222 cf(i,0)=0.0_r8
223 du(i,0)=0.0_r8
224 dv(i,0)=0.0_r8
225 END DO
227 DO i=istrm1,iendp1
228 cff=1.0_r8/(2.0_r8*hz(i,j,k+1)+ &
229 & hz(i,j,k)*(2.0_r8-cf(i,k-1)))
230 cf(i,k)=cff*hz(i,j,k+1)
231 du(i,k)=cff*(3.0_r8*(u(i ,j,k+1,nstp)-u(i, j,k,nstp)+ &
232 & u(i+1,j,k+1,nstp)-u(i+1,j,k,nstp))- &
233 & hz(i,j,k)*du(i,k-1))
234 dv(i,k)=cff*(3.0_r8*(v(i,j ,k+1,nstp)-v(i,j ,k,nstp)+ &
235 & v(i,j+1,k+1,nstp)-v(i,j+1,k,nstp))- &
236 & hz(i,j,k)*dv(i,k-1))
237 END DO
238 END DO
239 DO i=istrm1,iendp1
242 END DO
244 DO i=istrm1,iendp1
245 du(i,k)=du(i,k)-cf(i,k)*du(i,k+1)
246 dv(i,k)=dv(i,k)-cf(i,k)*dv(i,k+1)
247 END DO
248 END DO
250 DO i=istrm1,iendp1
251 shear2(i,j,k)=du(i,k)*du(i,k)+dv(i,k)*dv(i,k)
252 END DO
253 END DO
254 END DO
255# else
257 DO j=jstrm1,jendp1
258 DO i=istrm1,iendp1
259 cff=0.5_r8/(z_r(i,j,k+1)-z_r(i,j,k))
260 shear2(i,j,k)=(cff*(u(i ,j,k+1,nstp)-u(i ,j,k,nstp)+ &
261 & u(i+1,j,k+1,nstp)-u(i+1,j,k,nstp)))**2+ &
262 & (cff*(v(i,j ,k+1,nstp)-v(i,j ,k,nstp)+ &
263 & v(i,j+1,k+1,nstp)-v(i,j+1,k,nstp)))**2
264 END DO
265 END DO
266 END DO
267# endif
268
269
270
272 DO j=jstr-1,jend+1
273 DO i=istr-1,iend+1
274 buoy2(i,j,k)=bvf(i,j,k)
275 END DO
276 END DO
277 END DO
278# ifdef N2S2_HORAVG
279
280
281
282
283
284
286 IF (
domain(ng)%Western_Edge(tile))
THEN
287 DO j=max(1,jstr-1),min(jend+1,
mm(ng))
288 shear2(istr-1,j,k)=shear2(istr,j,k)
289 END DO
290 END IF
291 IF (
domain(ng)%Eastern_Edge(tile))
THEN
292 DO j=max(1,jstr-1),min(jend+1,
mm(ng))
293 shear2(iend+1,j,k)=shear2(iend,j,k)
294 END DO
295 END IF
296 IF (
domain(ng)%Southern_Edge(tile))
THEN
297 DO i=max(1,istr-1),min(iend+1,
lm(ng))
298 shear2(i,jstr-1,k)=shear2(i,jstr,k)
299 END DO
300 END IF
301 IF (
domain(ng)%Northern_Edge(tile))
THEN
302 DO i=max(1,istr-1),min(iend+1,
lm(ng))
303 shear2(i,jend+1,k)=shear2(i,jend,k)
304 END DO
305 END IF
306 IF (
domain(ng)%SouthWest_Corner(tile))
THEN
307 shear2(istr-1,jstr-1,k)=shear2(istr,jstr,k)
308 END IF
309 IF (
domain(ng)%NorthWest_Corner(tile))
THEN
310 shear2(istr-1,jend+1,k)=shear2(istr,jend,k)
311 END IF
312 IF (
domain(ng)%SouthEast_Corner(tile))
THEN
313 shear2(iend+1,jstr-1,k)=shear2(iend,jstr,k)
314 END IF
315 IF (
domain(ng)%NorthEast_Corner(tile))
THEN
316 shear2(iend+1,jend+1,k)=shear2(iend,jend,k)
317 END IF
318
319
320
321 DO j=jstr-1,jend
322 DO i=istr-1,iend
323 buoy2(i,j,0)=0.25_r8*(buoy2(i,j ,k)+buoy2(i+1,j ,k)+ &
324 & buoy2(i,j+1,k)+buoy2(i+1,j+1,k))
325 shear2(i,j,0)=0.25_r8*(shear2(i,j ,k)+shear2(i+1,j ,k)+ &
326 & shear2(i,j+1,k)+shear2(i+1,j+1,k))
327 END DO
328 END DO
329 DO j=jstr,jend
330 DO i=istr,iend
331 buoy2(i,j,k)=0.25_r8*(buoy2(i,j ,0)+buoy2(i-1,j ,0)+ &
332 & buoy2(i,j-1,0)+buoy2(i-1,j-1,0))
333 shear2(i,j,k)=0.25_r8*(shear2(i,j ,0)+shear2(i-1,j ,0)+ &
334 & shear2(i,j-1,0)+shear2(i-1,j-1,0))
335 END DO
336 END DO
337 END DO
338# endif
339
340
341
342
343
344
345
346
347
348
350# ifdef K_C2ADVECTION
351
352
353
354 DO j=jstr,jend
355 DO i=istr,iend+1
356 cff=0.25_r8*(huon(i,j,k)+huon(i,j,k+1))
357 fxk(i,j)=cff*(tke(i,j,k,3)+tke(i-1,j,k,3))
358 fxp(i,j)=cff*(gls(i,j,k,3)+gls(i-1,j,k,3))
359 END DO
360 END DO
361 DO j=jstr,jend+1
362 DO i=istr,iend
363 cff=0.25_r8*(hvom(i,j,k)+hvom(i,j,k+1))
364 fek(i,j)=cff*(tke(i,j,k,3)+tke(i,j-1,k,3))
365 fep(i,j)=cff*(gls(i,j,k,3)+gls(i,j-1,k,3))
366 END DO
367 END DO
368# else
369 DO j=jstr,jend
370 DO i=istrm1,iendp2
371 gradk(i,j)=(tke(i,j,k,3)-tke(i-1,j,k,3))
372# ifdef MASKING
373 gradk(i,j)=gradk(i,j)*umask(i,j)
374# endif
375 gradp(i,j)=(gls(i,j,k,3)-gls(i-1,j,k,3))
376# ifdef MASKING
377 gradp(i,j)=gradp(i,j)*umask(i,j)
378# endif
379 END DO
380 END DO
382 IF (
domain(ng)%Western_Edge(tile))
THEN
383 DO j=jstr,jend
384 gradk(istr-1,j)=gradk(istr,j)
385 gradp(istr-1,j)=gradp(istr,j)
386 END DO
387 END IF
388 END IF
390 IF (
domain(ng)%Eastern_Edge(tile))
THEN
391 DO j=jstr,jend
392 gradk(iend+2,j)=gradk(iend+1,j)
393 gradp(iend+2,j)=gradp(iend+1,j)
394 END DO
395 END IF
396 END IF
397# ifdef K_C4ADVECTION
398
399
400
401 cff1=1.0_r8/6.0_r8
402 DO j=jstr,jend
403 DO i=istr,iend+1
404 cff=0.5_r8*(huon(i,j,k)+huon(i,j,k+1))
405 fxk(i,j)=cff*0.5_r8*(tke(i-1,j,k,3)+tke(i,j,k,3)- &
406 & cff1*(gradk(i+1,j)-gradk(i-1,j)))
407 fxp(i,j)=cff*0.5_r8*(gls(i-1,j,k,3)+gls(i,j,k,3)- &
408 & cff1*(gradp(i+1,j)-gradp(i-1,j)))
409 END DO
410 END DO
411# else
412
413
414
415
416 DO j=jstr,jend
417 DO i=istr-1,iend+1
418 curvk(i,j)=gradk(i+1,j)-gradk(i,j)
419 curvp(i,j)=gradp(i+1,j)-gradp(i,j)
420 END DO
421 END DO
422 DO j=jstr,jend
423 DO i=istr,iend+1
424 cff=0.5_r8*(huon(i,j,k)+huon(i,j,k+1))
425 IF (cff.gt.0.0_r8) THEN
426 cff1=curvk(i-1,j)
427 cff2=curvp(i-1,j)
428 ELSE
429 cff1=curvk(i,j)
430 cff2=curvp(i,j)
431 END IF
432 fxk(i,j)=cff*0.5_r8*(tke(i-1,j,k,3)+tke(i,j,k,3)- &
433 & gadv*cff1)
434 fxp(i,j)=cff*0.5_r8*(gls(i-1,j,k,3)+gls(i,j,k,3)- &
435 & gadv*cff2)
436 END DO
437 END DO
438# endif
439 DO j=jstrm1,jendp2
440 DO i=istr,iend
441 gradk(i,j)=(tke(i,j,k,3)-tke(i,j-1,k,3))
442# ifdef MASKING
443 gradk(i,j)=gradk(i,j)*vmask(i,j)
444# endif
445 gradp(i,j)=(gls(i,j,k,3)-gls(i,j-1,k,3))
446# ifdef MASKING
447 gradp(i,j)=gradp(i,j)*vmask(i,j)
448# endif
449 END DO
450 END DO
452 IF (
domain(ng)%Southern_Edge(tile))
THEN
453 DO i=istr,iend
454 gradk(i,jstr-1)=gradk(i,jstr)
455 gradp(i,jstr-1)=gradp(i,jstr)
456 END DO
457 END IF
458 END IF
460 IF (
domain(ng)%Northern_Edge(tile))
THEN
461 DO i=istr,iend
462 gradk(i,jend+2)=gradk(i,jend+1)
463 gradp(i,jend+2)=gradp(i,jend+1)
464 END DO
465 END IF
466 END IF
467# ifdef K_C4ADVECTION
468 cff1=1.0_r8/6.0_r8
469 DO j=jstr,jend+1
470 DO i=istr,iend
471 cff=0.5_r8*(hvom(i,j,k)+hvom(i,j,k+1))
472 fek(i,j)=cff*0.5_r8*(tke(i,j-1,k,3)+tke(i,j,k,3)- &
473 & cff1*(gradk(i,j+1)-gradk(i,j-1)))
474 fep(i,j)=cff*0.5_r8*(gls(i,j-1,k,3)+gls(i,j,k,3)- &
475 & cff1*(gradp(i,j+1)-gradp(i,j-1)))
476 END DO
477 END DO
478# else
479 DO j=jstr-1,jend+1
480 DO i=istr,iend
481 curvk(i,j)=gradk(i,j+1)-gradk(i,j)
482 curvp(i,j)=gradp(i,j+1)-gradp(i,j)
483 END DO
484 END DO
485 DO j=jstr,jend+1
486 DO i=istr,iend
487 cff=0.5_r8*(hvom(i,j,k)+hvom(i,j,k+1))
488 IF (cff.gt.0.0_r8) THEN
489 cff1=curvk(i,j-1)
490 cff2=curvp(i,j-1)
491 ELSE
492 cff1=curvk(i,j)
493 cff2=curvp(i,j)
494 END IF
495 fek(i,j)=cff*0.5_r8*(tke(i,j-1,k,3)+tke(i,j,k,3)- &
496 & gadv*cff1)
497 fep(i,j)=cff*0.5_r8*(gls(i,j-1,k,3)+gls(i,j,k,3)- &
498 & gadv*cff2)
499 END DO
500 END DO
501# endif
502# endif
503
504
505
506 DO j=jstr,jend
507 DO i=istr,iend
508 cff=
dt(ng)*pm(i,j)*pn(i,j)
509 tke(i,j,k,nnew)=tke(i,j,k,nnew)- &
510 & cff*(fxk(i+1,j)-fxk(i,j)+ &
511 & fek(i,j+1)-fek(i,j))
512 gls(i,j,k,nnew)=gls(i,j,k,nnew)- &
513 & cff*(fxp(i+1,j)-fxp(i,j)+ &
514 & fep(i,j+1)-fep(i,j))
515 END DO
516 END DO
517 END DO
518
519
520
521 DO j=jstr,jend
522# ifdef K_C2ADVECTION
524 DO i=istr,iend
525 cff=0.25_r8*(w(i,j,k)+w(i,j,k-1))
526 fck(i,k)=cff*(tke(i,j,k,3)+tke(i,j,k-1,3))
527 fcp(i,k)=cff*(gls(i,j,k,3)+gls(i,j,k-1,3))
528 END DO
529 END DO
530# else
531 cff1=7.0_r8/12.0_r8
532 cff2=1.0_r8/12.0_r8
534 DO i=istr,iend
535 cff=0.5*(w(i,j,k)+w(i,j,k-1))
536 fck(i,k)=cff*(cff1*(tke(i,j,k-1,3)+ &
537 & tke(i,j,k ,3))- &
538 & cff2*(tke(i,j,k-2,3)+ &
539 & tke(i,j,k+1,3)))
540 fcp(i,k)=cff*(cff1*(gls(i,j,k-1,3)+ &
541 & gls(i,j,k ,3))- &
542 & cff2*(gls(i,j,k-2,3)+ &
543 & gls(i,j,k+1,3)))
544 END DO
545 END DO
546 cff1=1.0_r8/3.0_r8
547 cff2=5.0_r8/6.0_r8
548 cff3=1.0_r8/6.0_r8
549 DO i=istr,iend
550 cff=0.5_r8*(w(i,j,0)+w(i,j,1))
551 fck(i,1)=cff*(cff1*tke(i,j,0,3)+ &
552 & cff2*tke(i,j,1,3)- &
553 & cff3*tke(i,j,2,3))
554 fcp(i,1)=cff*(cff1*gls(i,j,0,3)+ &
555 & cff2*gls(i,j,1,3)- &
556 & cff3*gls(i,j,2,3))
557 cff=0.5_r8*(w(i,j,
n(ng))+w(i,j,
n(ng)-1))
558 fck(i,
n(ng))=cff*(cff1*tke(i,j,
n(ng) ,3)+ &
559 & cff2*tke(i,j,
n(ng)-1,3)- &
560 & cff3*tke(i,j,
n(ng)-2,3))
561 fcp(i,
n(ng))=cff*(cff1*gls(i,j,
n(ng) ,3)+ &
562 & cff2*gls(i,j,
n(ng)-1,3)- &
563 & cff3*gls(i,j,
n(ng)-2,3))
564 END DO
565# endif
566
567
568
570 DO i=istr,iend
571 cff=
dt(ng)*pm(i,j)*pn(i,j)
572 tke(i,j,k,nnew)=tke(i,j,k,nnew)- &
573 & cff*(fck(i,k+1)-fck(i,k))
574 gls(i,j,k,nnew)=gls(i,j,k,nnew)- &
575 & cff*(fcp(i,k+1)-fcp(i,k))
576 END DO
577 END DO
578
579
580
581
582
583
584
585
588 DO i=istr,iend
589 fck(i,k)=cff*(akk(i,j,k)+akk(i,j,k-1))/hz(i,j,k)
590 cf(i,k)=0.0_r8
591 END DO
592 END DO
593
594
595
598 DO i=istr,iend
599
600
601
602
603 IF ((buoy2(i,j,k).gt.-5.0e-5_r8).and. &
604 & (buoy2(i,j,k).lt.0.0_r8)) THEN
605 strat2=0.0_r8
606 ELSE
607 strat2=buoy2(i,j,k)
608 END IF
609 qprod=shear2(i,j,k)*(akv(i,j,k)-
akv_bak(ng))- &
611
612
613
614 ls_unlmt=max(eps, &
615 & gls(i,j,k,nstp)/(max(tke(i,j,k,nstp),eps)))
616
617
618
619 cff1=0.5_r8*(hz(i,j,k)+hz(i,j,k+1))
620 tke(i,j,k,nnew)=tke(i,j,k,nnew)+ &
621 &
dt(ng)*cff1*qprod*2.0_r8
622 gls(i,j,k,nnew)=gls(i,j,k,nnew)+ &
623 &
dt(ng)*cff1*qprod*
my_e1*ls_unlmt
624
625
626
627
628 qdiss=
dt(ng)*sqrt(tke(i,j,k,nstp))/(
my_b1*ls_unlmt)
629 cff=ls_unlmt*(1.0_r8/(z_w(i,j,
n(ng))-z_w(i,j,k))+ &
630 & 1.0_r8/(z_w(i,j,k)-z_w(i,j,0)))
631 wscale=1.0_r8+cff3*cff*cff
632 bck(i,k)=cff1*(1.0_r8+2.0_r8*qdiss)-fck(i,k)-fck(i,k+1)
633 bcp(i,k)=cff1*(1.0_r8+wscale*qdiss)-fck(i,k)-fck(i,k+1)
634 END DO
635 END DO
636
637
638
639
640
641
642
643 DO i=istr,iend
645 & sqrt((sustr(i,j)+sustr(i+1,j))**2+ &
646 & (svstr(i,j)+svstr(i,j+1))**2)
647 gls(i,j,
n(ng),nnew)=0.0_r8
649 & sqrt((bustr(i,j)+bustr(i+1,j))**2+ &
650 & (bvstr(i,j)+bvstr(i,j+1))**2)
651 gls(i,j,0,nnew)=0.0_r8
652 END DO
653
654
655
656 DO i=istr,iend
657 cff=1.0_r8/bck(i,
n(ng)-1)
658 cf(i,
n(ng)-1)=cff*fck(i,
n(ng)-1)
659 tke(i,j,
n(ng)-1,nnew)=cff*(tke(i,j,
n(ng)-1,nnew)- &
660 & fck(i,
n(ng))*tke(i,j,
n(ng),nnew))
661 END DO
663 DO i=istr,iend
664 cff=1.0_r8/(bck(i,k)-cf(i,k+1)*fck(i,k+1))
665 cf(i,k)=cff*fck(i,k)
666 tke(i,j,k,nnew)=cff*(tke(i,j,k,nnew)- &
667 & fck(i,k+1)*tke(i,j,k+1,nnew))
668 END DO
669 END DO
671 DO i=istr,iend
672 tke(i,j,k,nnew)=tke(i,j,k,nnew)-cf(i,k)*tke(i,j,k-1,nnew)
673 END DO
674 END DO
675
676
677
678 DO i=istr,iend
679 cff=1.0_r8/bcp(i,
n(ng)-1)
680 cf(i,
n(ng)-1)=cff*fck(i,
n(ng)-1)
681 gls(i,j,
n(ng)-1,nnew)=cff*(gls(i,j,
n(ng)-1,nnew)- &
682 & fck(i,
n(ng))*gls(i,j,
n(ng),nnew))
683 END DO
685 DO i=istr,iend
686 cff=1.0_r8/(bcp(i,k)-cf(i,k+1)*fck(i,k+1))
687 cf(i,k)=cff*fck(i,k)
688 gls(i,j,k,nnew)=cff*(gls(i,j,k,nnew)- &
689 & fck(i,k+1)*gls(i,j,k+1,nnew))
690 END DO
691 END DO
693 DO i=istr,iend
694 gls(i,j,k,nnew)=gls(i,j,k,nnew)-cf(i,k)*gls(i,j,k-1,nnew)
695 END DO
696 END DO
697
698
699
700
701
703 DO i=istr,iend
704
705
706
707
708
709 tke(i,j,k,nnew)=max(tke(i,j,k,nnew),
my_qmin)
710 gls(i,j,k,nnew)=max(gls(i,j,k,nnew),
my_qmin)
711 ls_unlmt=gls(i,j,k,nnew)/tke(i,j,k,nnew)
712 ls_lmt=min(ls_unlmt, &
713 &
my_lmax*sqrt(tke(i,j,k,nnew)/ &
714 & (max(0.0_r8,buoy2(i,j,k))+eps)))
715
716
717
718
719
720
721
722 gh=min(
my_gh0,-buoy2(i,j,k)*ls_lmt*ls_lmt/ &
723 & tke(i,j,k,nnew))
726# ifdef KANTHA_CLAYSON
728# else
730# endif
731
732
733
734
735
736 ql=0.5_r8*(ls_lmt*sqrt(tke(i,j,k,nnew))+ &
737 & lscale(i,j,k)*sqrt(tke(i,j,k,nstp)))
740 akt(i,j,k,itrc)=
akt_bak(itrc,ng)+ql*sh
741 END DO
742
743
744
745
746
748
749
750
751 lscale(i,j,k)=ls_lmt
752
753# if defined LIMIT_VDIFF || defined LIMIT_VVISC
754
755
756
757
758
759
760# ifdef LIMIT_VDIFF
762 akt(i,j,k,itrc)=min(
akt_limit(itrc,ng), akt(i,j,k,itrc))
763 END DO
764# endif
765# ifdef LIMIT_VVISC
766 akv(i,j,k)=min(
akv_limit(ng), akv(i,j,k))
767# endif
768# endif
769 END DO
770 END DO
771 END DO
772
773
774
775
776
778 IF (
domain(ng)%Western_Edge(tile))
THEN
779 DO j=jstr,jend
781 akt(istr-1,j,k,itrc)=akt(istr,j,k,itrc)
782 END DO
783 akv(istr-1,j,k)=akv(istr,j,k)
784 END DO
785 END IF
786 IF (
domain(ng)%Eastern_Edge(tile))
THEN
787 DO j=jstr,jend
789 akt(iend-1,j,k,itrc)=akt(iend,j,k,itrc)
790 END DO
791 akv(iend-1,j,k)=akv(iend,j,k)
792 END DO
793
794 END IF
795 IF (
domain(ng)%Southern_Edge(tile))
THEN
796 DO i=istr,iend
798 akt(i,jstr-1,k,itrc)=akt(i,jstr,k,itrc)
799 END DO
800 akv(i,jstr-1,k)=akv(i,jstr,k)
801 END DO
802 END IF
803 IF (
domain(ng)%Northern_Edge(tile))
THEN
804 DO i=istr,iend
806 akt(i,jend+1,k,itrc)=akt(i,jend,k,itrc)
807 END DO
808 akv(i,jend+1,k)=akv(i,jend,k)
809 END DO
810 END IF
811 IF (
domain(ng)%SouthWest_Corner(tile))
THEN
813 akt(istr-1,jstr-1,k,itrc)=0.5_r8* &
814 & (akt(istr ,jstr-1,k,itrc)+ &
815 & akt(istr-1,jstr ,k,itrc))
816 END DO
817 akv(istr-1,jstr-1,k)=0.5_r8* &
818 & (akv(istr ,jstr-1,k)+ &
819 & akv(istr-1,jstr ,k))
820 END IF
821 IF (
domain(ng)%SouthEast_Corner(tile))
THEN
823 akt(iend+1,jstr-1,k,itrc)=0.5_r8* &
824 & (akt(iend ,jstr-1,k,itrc)+ &
825 & akt(iend+1,jstr ,k,itrc))
826 END DO
827 akv(iend+1,jstr-1,k)=0.5_r8* &
828 & (akv(iend ,jstr-1,k)+ &
829 & akv(iend+1,jstr ,k))
830 END IF
831 IF (
domain(ng)%NorthWest_Corner(tile))
THEN
833 akt(istr-1,jend+1,k,itrc)=0.5_r8* &
834 & (akt(istr ,jend+1,k,itrc)+ &
835 & akt(istr-1,jend ,k,itrc))
836 END DO
837 akv(istr-1,jend+1,k)=0.5_r8* &
838 & (akv(istr ,jend+1,k)+ &
839 & akv(istr-1,jend ,k))
840 END IF
841 IF (
domain(ng)%NorthEast_Corner(tile))
THEN
843 akt(iend+1,jend+1,k,itrc)=0.5_r8* &
844 & (akt(iend ,jend+1,k,itrc)+ &
845 & akt(iend+1,jend ,k,itrc))
846 END DO
847 akv(iend+1,jend+1,k)=0.5_r8* &
848 & (akv(iend ,jend+1,k)+ &
849 & akv(iend+1,jend ,k))
850 END IF
851 END DO
852
854 & lbi, ubi, lbj, ubj,
n(ng), &
855 & imins, imaxs, jmins, jmaxs, &
856 & nnew, nstp, &
857 & gls, tke)
858
861 & lbi, ubi, lbj, ubj, 0,
n(ng), &
862 & tke(:,:,:,nnew))
864 & lbi, ubi, lbj, ubj, 0,
n(ng), &
865 & gls(:,:,:,nnew))
867 & lbi, ubi, lbj, ubj, 0,
n(ng), &
868 & akv)
871 & lbi, ubi, lbj, ubj, 0,
n(ng), &
872 & akt(:,:,:,itrc))
873 END DO
874 END IF
875
876# ifdef DISTRIBUTE
878 & lbi, ubi, lbj, ubj, 0,
n(ng), &
881 & tke(:,:,:,nnew), &
882 & gls(:,:,:,nnew), &
883 & akv)
885 & lbi, ubi, lbj, ubj, 0,
n(ng), 1,
nat, &
888 & akt)
889# endif
890
891 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 lm
integer, dimension(:), allocatable mm
real(r8), parameter my_gh0
real(r8), parameter my_sq
real(r8), parameter my_lmax
real(dp), dimension(:), allocatable dt
real(r8), parameter my_qmin
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
real(r8), parameter my_e1
real(r8), parameter my_b1
real(r8), dimension(:), allocatable akk_bak
real(r8), dimension(:,:), allocatable akt_bak
real(r8), dimension(:), allocatable akv_bak
logical, dimension(:,:), allocatable compositegrid
integer, parameter isouth
real(r8), dimension(:,:), allocatable akt_limit
real(r8), dimension(:), allocatable akv_limit
real(r8), parameter my_e2
integer, parameter inorth
subroutine mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, a, b, c)
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)