ROMS
Loading...
Searching...
No Matches
u2dbc_ex.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE u2dbc_mod
3!
4!git $Id$
5!=======================================================================
6! Copyright (c) 2002-2025 The ROMS Group !
7! Licensed under a MIT/X style license !
8! See License_ROMS.md Hernan G. Arango !
9!========================================== Alexander F. Shchepetkin ===
10! !
11! This subroutine sets lateral boundary conditions for vertically !
12! integrated U-velocity. !
13! !
14!=======================================================================
15!
16 implicit none
17!
18 PRIVATE
19 PUBLIC :: u2dbc, u2dbc_tile
20!
21 CONTAINS
22!
23!***********************************************************************
24 SUBROUTINE u2dbc (ng, tile, kout)
25!***********************************************************************
26!
27 USE mod_param
28 USE mod_ocean
29 USE mod_stepping
30!
31! Imported variable declarations.
32!
33 integer, intent(in) :: ng, tile, kout
34!
35! Local variable declarations.
36!
37#include "tile.h"
38!
39 CALL u2dbc_tile (ng, tile, &
40 & lbi, ubi, lbj, ubj, &
41 & imins, imaxs, jmins, jmaxs, &
42 & krhs(ng), kstp(ng), kout, &
43 & ocean(ng) % ubar, &
44 & ocean(ng) % vbar, &
45 & ocean(ng) % zeta)
46
47 RETURN
48 END SUBROUTINE u2dbc
49!
50!***********************************************************************
51 SUBROUTINE u2dbc_tile (ng, tile, &
52 & LBi, UBi, LBj, UBj, &
53 & IminS, ImaxS, JminS, JmaxS, &
54 & krhs, kstp, kout, &
55 & ubar, vbar, zeta)
56!***********************************************************************
57!
58 USE mod_param
59 USE mod_boundary
60 USE mod_clima
61 USE mod_forces
62 USE mod_grid
63 USE mod_ncparam
64 USE mod_scalars
65!
66! Imported variable declarations.
67!
68 integer, intent(in) :: ng, tile
69 integer, intent(in) :: LBi, UBi, LBj, UBj
70 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
71 integer, intent(in) :: krhs, kstp, kout
72!
73#ifdef ASSUMED_SHAPE
74 real(r8), intent(in) :: vbar(LBi:,LBj:,:)
75 real(r8), intent(in) :: zeta(LBi:,LBj:,:)
76
77 real(r8), intent(inout) :: ubar(LBi:,LBj:,:)
78#else
79 real(r8), intent(in) :: vbar(LBi:UBi,LBj:UBj,:)
80 real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,:)
81
82 real(r8), intent(inout) :: ubar(LBi:UBi,LBj:UBj,:)
83#endif
84!
85! Local variable declarations.
86!
87 integer :: Imin, Imax
88 integer :: i, j, know
89
90 real(r8), parameter :: eps = 1.0e-20_r8
91
92 real(r8) :: Ce, Cx
93 real(r8) :: bry_pgr, bry_cor, bry_str, bry_val
94 real(r8) :: cff, cff1, cff2, dt2d, dUde, dUdt, dUdx
95 real(r8) :: obc_in, obc_out, tau
96
97 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
98
99#include "set_bounds.h"
100!
101!-----------------------------------------------------------------------
102! Set time-indices
103!-----------------------------------------------------------------------
104!
105 IF (first_2d_step) THEN
106 know=krhs
107 dt2d=dtfast(ng)
108 ELSE IF (predictor_2d_step(ng)) THEN
109 know=krhs
110 dt2d=2.0_r8*dtfast(ng)
111 ELSE
112 know=kstp
113 dt2d=dtfast(ng)
114 END IF
115!
116!-----------------------------------------------------------------------
117! Lateral boundary conditions at the western edge.
118!-----------------------------------------------------------------------
119!
120 IF (domain(ng)%Western_Edge(tile)) THEN
121!
122! Western edge, implicit upstream radiation condition.
123!
124 IF (lbc(iwest,isubar,ng)%radiation) THEN
125 DO j=jstr,jend+1
126 grad(istr ,j)=ubar(istr ,j ,know)- &
127 & ubar(istr ,j-1,know)
128 grad(istr+1,j)=ubar(istr+1,j ,know)- &
129 & ubar(istr+1,j-1,know)
130 END DO
131 DO j=jstr,jend
132 IF (lbc_apply(ng)%west(j)) THEN
133 dudt=ubar(istr+1,j,know)-ubar(istr+1,j,kout)
134 dudx=ubar(istr+1,j,know)-ubar(istr+2,j,know)
135
136 IF (lbc(iwest,isubar,ng)%nudging) THEN
137 IF (lnudgem2clm(ng)) THEN
138 obc_out=0.5_r8* &
139 & (clima(ng)%M2nudgcof(istr-1,j)+ &
140 & clima(ng)%M2nudgcof(istr ,j))
141 obc_in =obcfac(ng)*obc_out
142 ELSE
143 obc_out=m2obc_out(ng,iwest)
144 obc_in =m2obc_in(ng,iwest)
145 END IF
146 IF ((dudt*dudx).lt.0.0_r8) THEN
147 tau=obc_in
148 ELSE
149 tau=obc_out
150 END IF
151 tau=tau*dt2d
152 END IF
153
154 IF ((dudt*dudx).lt.0.0_r8) dudt=0.0_r8
155 IF ((dudt*(grad(istr+1,j )+ &
156 & grad(istr+1,j+1))).gt.0.0_r8) THEN
157 dude=grad(istr+1,j )
158 ELSE
159 dude=grad(istr+1,j+1)
160 END IF
161 cff=dudt/max(dudx*dudx+dude*dude,eps)
162 cx=min(1.0_r8,cff*dudx)
163#ifdef RADIATION_2D
164 ce=min(1.0_r8,max(-1.0_r8,cff*dude))
165#else
166 ce=0.0_r8
167#endif
168#if defined CELERITY_WRITE && defined FORWARD_WRITE
169 boundary(ng)%ubar_west_Cx(j)=cx
170 boundary(ng)%ubar_west_Ce(j)=ce
171 boundary(ng)%ubar_west_C2(j)=cff
172#endif
173 ubar(istr,j,kout)=(1.0_r8-cx)*ubar(istr,j,know)+ &
174 & cx*ubar(istr+1,j,know)- &
175 & max(ce,0.0_r8)*grad(istr,j )- &
176 & min(ce,0.0_r8)*grad(istr,j+1)
177
178 IF (lbc(iwest,isubar,ng)%nudging) THEN
179 ubar(istr,j,kout)=ubar(istr,j,kout)+ &
180 & tau*(boundary(ng)%ubar_west(j)- &
181 & ubar(istr,j,know))
182 END IF
183#ifdef MASKING
184 ubar(istr,j,kout)=ubar(istr,j,kout)* &
185 & grid(ng)%umask(istr,j)
186#endif
187 END IF
188 END DO
189!
190! Western edge, Flather boundary condition.
191!
192 ELSE IF (lbc(iwest,isubar,ng)%Flather) THEN
193 DO j=jstr,jend
194 IF (lbc_apply(ng)%west(j)) THEN
195#if defined SSH_TIDES && !defined UV_TIDES
196 IF (lbc(iwest,isfsur,ng)%acquire) THEN
197 bry_pgr=-g*(zeta(istr,j,know)- &
198 & boundary(ng)%zeta_west(j))* &
199 & 0.5_r8*grid(ng)%pm(istr,j)
200 ELSE
201 bry_pgr=-g*(zeta(istr ,j,know)- &
202 & zeta(istr-1,j,know))* &
203 & 0.5_r8*(grid(ng)%pm(istr-1,j)+ &
204 & grid(ng)%pm(istr ,j))
205 END IF
206# ifdef UV_COR
207 bry_cor=0.125_r8*(vbar(istr-1,j ,know)+ &
208 & vbar(istr-1,j+1,know)+ &
209 & vbar(istr ,j ,know)+ &
210 & vbar(istr ,j+1,know))* &
211 & (grid(ng)%f(istr-1,j)+ &
212 & grid(ng)%f(istr ,j))
213# else
214 bry_cor=0.0_r8
215# endif
216 cff1=1.0_r8/(0.5_r8*(grid(ng)%h(istr-1,j)+ &
217 & zeta(istr-1,j,know)+ &
218 & grid(ng)%h(istr ,j)+ &
219 & zeta(istr ,j,know)))
220 bry_str=cff1*(forces(ng)%sustr(istr,j)- &
221 & forces(ng)%bustr(istr,j))
222 cx=1.0_r8/sqrt(g*0.5_r8*(grid(ng)%h(istr-1,j)+ &
223 & zeta(istr-1,j,know)+ &
224 & grid(ng)%h(istr ,j)+ &
225 & zeta(istr ,j,know)))
226 cff2=grid(ng)%om_u(istr,j)*cx
227!! cff2=dt2d
228 bry_val=ubar(istr+1,j,know)+ &
229 & cff2*(bry_pgr+ &
230 & bry_cor+ &
231 & bry_str)
232#else
233 bry_val=boundary(ng)%ubar_west(j)
234#endif
235 cff=1.0_r8/(0.5_r8*(grid(ng)%h(istr-1,j)+ &
236 & zeta(istr-1,j,know)+ &
237 & grid(ng)%h(istr ,j)+ &
238 & zeta(istr ,j,know)))
239 cx=sqrt(g*cff)
240 ubar(istr,j,kout)=bry_val- &
241 & cx*(0.5_r8*(zeta(istr-1,j,know)+ &
242 & zeta(istr ,j,know))- &
243 & boundary(ng)%zeta_west(j))
244#ifdef MASKING
245 ubar(istr,j,kout)=ubar(istr,j,kout)* &
246 & grid(ng)%umask(istr,j)
247#endif
248 END IF
249 END DO
250!
251! Western edge, clamped boundary condition.
252!
253 ELSE IF (lbc(iwest,isubar,ng)%clamped) THEN
254 DO j=jstr,jend
255 IF (lbc_apply(ng)%west(j)) THEN
256 ubar(istr,j,kout)=boundary(ng)%ubar_west(j)
257#ifdef MASKING
258 ubar(istr,j,kout)=ubar(istr,j,kout)* &
259 & grid(ng)%umask(istr,j)
260#endif
261 END IF
262 END DO
263!
264! Western edge, gradient boundary condition.
265!
266 ELSE IF (lbc(iwest,isubar,ng)%gradient) THEN
267 DO j=jstr,jend
268 IF (lbc_apply(ng)%west(j)) THEN
269 ubar(istr,j,kout)=ubar(istr+1,j,kout)
270#ifdef MASKING
271 ubar(istr,j,kout)=ubar(istr,j,kout)* &
272 & grid(ng)%umask(istr,j)
273#endif
274 END IF
275 END DO
276!
277! Western edge, reduced-physics boundary condition.
278!
279 ELSE IF (lbc(iwest,isubar,ng)%reduced) THEN
280 DO j=jstr,jend
281 IF (lbc_apply(ng)%west(j)) THEN
282 IF (lbc(iwest,isfsur,ng)%acquire) THEN
283 bry_pgr=-g*(zeta(istr,j,know)- &
284 & boundary(ng)%zeta_west(j))* &
285 & 0.5_r8*grid(ng)%pm(istr,j)
286 ELSE
287 bry_pgr=-g*(zeta(istr ,j,know)- &
288 & zeta(istr-1,j,know))* &
289 & 0.5_r8*(grid(ng)%pm(istr-1,j)+ &
290 & grid(ng)%pm(istr ,j))
291 END IF
292#ifdef UV_COR
293 bry_cor=0.125_r8*(vbar(istr-1,j ,know)+ &
294 & vbar(istr-1,j+1,know)+ &
295 & vbar(istr ,j ,know)+ &
296 & vbar(istr ,j+1,know))* &
297 & (grid(ng)%f(istr-1,j)+ &
298 & grid(ng)%f(istr ,j))
299#else
300 bry_cor=0.0_r8
301#endif
302 cff=1.0_r8/(0.5_r8*(grid(ng)%h(istr-1,j)+ &
303 & zeta(istr-1,j,know)+ &
304 & grid(ng)%h(istr ,j)+ &
305 & zeta(istr ,j,know)))
306 bry_str=cff*(forces(ng)%sustr(istr,j)- &
307 & forces(ng)%bustr(istr,j))
308 ubar(istr,j,kout)=ubar(istr,j,know)+ &
309 & dt2d*(bry_pgr+ &
310 & bry_cor+ &
311 & bry_str)
312#ifdef MASKING
313 ubar(istr,j,kout)=ubar(istr,j,kout)* &
314 & grid(ng)%umask(istr,j)
315#endif
316 END IF
317 END DO
318!
319! Western edge, closed boundary condition.
320!
321 ELSE IF (lbc(iwest,isubar,ng)%closed) THEN
322 DO j=jstr,jend
323 IF (lbc_apply(ng)%west(j)) THEN
324 ubar(istr,j,kout)=0.0_r8
325 END IF
326 END DO
327 END IF
328 END IF
329!
330!-----------------------------------------------------------------------
331! Lateral boundary conditions at the eastern edge.
332!-----------------------------------------------------------------------
333!
334 IF (domain(ng)%Eastern_Edge(tile)) THEN
335!
336! Eastern edge, implicit upstream radiation condition.
337!
338 IF (lbc(ieast,isubar,ng)%radiation) THEN
339 DO j=jstr,jend+1
340 grad(iend ,j)=ubar(iend ,j ,know)- &
341 & ubar(iend ,j-1,know)
342 grad(iend+1,j)=ubar(iend+1,j ,know)- &
343 & ubar(iend+1,j-1,know)
344 END DO
345 DO j=jstr,jend
346 IF (lbc_apply(ng)%east(j)) THEN
347 dudt=ubar(iend,j,know)-ubar(iend ,j,kout)
348 dudx=ubar(iend,j,know)-ubar(iend-1,j,know)
349
350 IF (lbc(ieast,isubar,ng)%nudging) THEN
351 IF (lnudgem2clm(ng)) THEN
352 obc_out=0.5_r8* &
353 & (clima(ng)%M2nudgcof(iend ,j)+ &
354 & clima(ng)%M2nudgcof(iend+1,j))
355 obc_in =obcfac(ng)*obc_out
356 ELSE
357 obc_out=m2obc_out(ng,ieast)
358 obc_in =m2obc_in(ng,ieast)
359 END IF
360 IF ((dudt*dudx).lt.0.0_r8) THEN
361 tau=obc_in
362 ELSE
363 tau=obc_out
364 END IF
365 tau=tau*dt2d
366 END IF
367
368 IF ((dudt*dudx).lt.0.0_r8) dudt=0.0_r8
369 IF ((dudt*(grad(iend,j )+ &
370 & grad(iend,j+1))).gt.0.0_r8) THEN
371 dude=grad(iend,j)
372 ELSE
373 dude=grad(iend,j+1)
374 END IF
375 cff=dudt/max(dudx*dudx+dude*dude,eps)
376 cx=min(1.0_r8,cff*dudx)
377#ifdef RADIATION_2D
378 ce=min(1.0_r8,max(-1.0_r8,cff*dude))
379#else
380 ce=0.0_r8
381#endif
382#if defined CELERITY_WRITE && defined FORWARD_WRITE
383 boundary(ng)%ubar_east_Cx(j)=cx
384 boundary(ng)%ubar_east_Ce(j)=ce
385 boundary(ng)%ubar_east_C2(j)=cff
386#endif
387 ubar(iend+1,j,kout)=(1.0_r8-cx)*ubar(iend+1,j,know)+ &
388 & cx*ubar(iend,j,know)- &
389 & max(ce,0.0_r8)*grad(iend+1,j )- &
390 & min(ce,0.0_r8)*grad(iend+1,j+1)
391
392 IF (lbc(ieast,isubar,ng)%nudging) THEN
393 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)+ &
394 & tau*(boundary(ng)%ubar_east(j)- &
395 & ubar(iend+1,j,know))
396 END IF
397#ifdef MASKING
398 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)* &
399 & grid(ng)%umask(iend+1,j)
400#endif
401 END IF
402 END DO
403!
404! Eastern edge, Flather boundary condition.
405!
406 ELSE IF (lbc(ieast,isubar,ng)%Flather) THEN
407 DO j=jstr,jend
408 IF (lbc_apply(ng)%east(j)) THEN
409#if defined SSH_TIDES && !defined UV_TIDES
410 IF (lbc(ieast,isfsur,ng)%acquire) THEN
411 bry_pgr=-g*(boundary(ng)%zeta_east(j)- &
412 & zeta(iend,j,know))* &
413 & 0.5_r8*grid(ng)%pm(iend,j)
414 ELSE
415 bry_pgr=-g*(zeta(iend+1,j,know)- &
416 & zeta(iend ,j,know))* &
417 & 0.5_r8*(grid(ng)%pm(iend ,j)+ &
418 & grid(ng)%pm(iend+1,j))
419 END IF
420# ifdef UV_COR
421 bry_cor=0.125_r8*(vbar(iend ,j ,know)+ &
422 & vbar(iend ,j+1,know)+ &
423 & vbar(iend+1,j ,know)+ &
424 & vbar(iend+1,j+1,know))* &
425 & (grid(ng)%f(iend ,j)+ &
426 & grid(ng)%f(iend+1,j))
427# else
428 bry_cor=0.0_r8
429# endif
430 cff1=1.0_r8/(0.5_r8*(grid(ng)%h(iend ,j)+ &
431 & zeta(iend ,j,know)+ &
432 & grid(ng)%h(iend+1,j)+ &
433 & zeta(iend+1,j,know)))
434 bry_str=cff1*(forces(ng)%sustr(iend+1,j)- &
435 & forces(ng)%bustr(iend+1,j))
436 cx=1.0_r8/sqrt(g*0.5_r8*(grid(ng)%h(iend+1,j)+ &
437 & zeta(iend+1,j,know)+ &
438 & grid(ng)%h(iend ,j)+ &
439 & zeta(iend ,j,know)))
440 cff2=grid(ng)%om_u(iend+1,j)*cx
441!! cff2=dt2d
442 bry_val=ubar(iend,j,know)+ &
443 & cff2*(bry_pgr+ &
444 & bry_cor+ &
445 & bry_str)
446#else
447 bry_val=boundary(ng)%ubar_east(j)
448#endif
449 cff=1.0_r8/(0.5_r8*(grid(ng)%h(iend ,j)+ &
450 & zeta(iend ,j,know)+ &
451 & grid(ng)%h(iend+1,j)+ &
452 & zeta(iend+1,j,know)))
453 cx=sqrt(g*cff)
454 ubar(iend+1,j,kout)=bry_val+ &
455 & cx*(0.5_r8*(zeta(iend ,j,know)+ &
456 & zeta(iend+1,j,know))- &
457 & boundary(ng)%zeta_east(j))
458#ifdef MASKING
459 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)* &
460 & grid(ng)%umask(iend+1,j)
461#endif
462 END IF
463 END DO
464!
465! Eastern edge, clamped boundary condition.
466!
467 ELSE IF (lbc(ieast,isubar,ng)%clamped) THEN
468 DO j=jstr,jend
469 IF (lbc_apply(ng)%east(j)) THEN
470 ubar(iend+1,j,kout)=boundary(ng)%ubar_east(j)
471#ifdef MASKING
472 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)* &
473 & grid(ng)%umask(iend+1,j)
474#endif
475 END IF
476 END DO
477!
478! Eastern edge, gradient boundary condition.
479!
480 ELSE IF (lbc(ieast,isubar,ng)%gradient) THEN
481 DO j=jstr,jend
482 IF (lbc_apply(ng)%east(j)) THEN
483 ubar(iend+1,j,kout)=ubar(iend,j,kout)
484#ifdef MASKING
485 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)* &
486 & grid(ng)%umask(iend+1,j)
487#endif
488 END IF
489 END DO
490!
491! Eastern edge, reduced-physics boundary condition.
492!
493 ELSE IF (lbc(ieast,isubar,ng)%reduced) THEN
494 DO j=jstr,jend
495 IF (lbc_apply(ng)%east(j)) THEN
496 IF (lbc(ieast,isfsur,ng)%acquire) THEN
497 bry_pgr=-g*(boundary(ng)%zeta_east(j)- &
498 & zeta(iend,j,know))* &
499 & 0.5_r8*grid(ng)%pm(iend,j)
500 ELSE
501 bry_pgr=-g*(zeta(iend+1,j,know)- &
502 & zeta(iend ,j,know))* &
503 & 0.5_r8*(grid(ng)%pm(iend ,j)+ &
504 & grid(ng)%pm(iend+1,j))
505 END IF
506#ifdef UV_COR
507 bry_cor=0.125_r8*(vbar(iend ,j ,know)+ &
508 & vbar(iend ,j+1,know)+ &
509 & vbar(iend+1,j ,know)+ &
510 & vbar(iend+1,j+1,know))* &
511 & (grid(ng)%f(iend ,j)+ &
512 & grid(ng)%f(iend+1,j))
513#else
514 bry_cor=0.0_r8
515#endif
516 cff=1.0_r8/(0.5_r8*(grid(ng)%h(iend ,j)+ &
517 & zeta(iend ,j,know)+ &
518 & grid(ng)%h(iend+1,j)+ &
519 & zeta(iend+1,j,know)))
520 bry_str=cff*(forces(ng)%sustr(iend+1,j)- &
521 & forces(ng)%bustr(iend+1,j))
522 ubar(iend+1,j,kout)=ubar(iend+1,j,know)+ &
523 & dt2d*(bry_pgr+ &
524 & bry_cor+ &
525 & bry_str)
526#ifdef MASKING
527 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)* &
528 & grid(ng)%umask(iend+1,j)
529#endif
530 END IF
531 END DO
532!
533! Eastern edge, closed boundary condition.
534!
535 ELSE IF (lbc(ieast,isubar,ng)%closed) THEN
536 DO j=jstr,jend
537 IF (lbc_apply(ng)%east(j)) THEN
538 ubar(iend+1,j,kout)=0.0_r8
539 END IF
540 END DO
541 END IF
542 END IF
543!
544!-----------------------------------------------------------------------
545! Lateral boundary conditions at the southern edge.
546!-----------------------------------------------------------------------
547!
548 IF (domain(ng)%Southern_Edge(tile)) THEN
549!
550! Southern edge, implicit upstream radiation condition.
551!
552 IF (lbc(isouth,isubar,ng)%radiation) THEN
553 DO i=istru-1,iend
554 grad(i,jstr-1)=ubar(i+1,jstr-1,know)- &
555 & ubar(i ,jstr-1,know)
556 grad(i,jstr )=ubar(i+1,jstr ,know)- &
557 & ubar(i ,jstr ,know)
558 END DO
559 DO i=istru,iend
560 IF (lbc_apply(ng)%south(i)) THEN
561 dudt=ubar(i,jstr,know)-ubar(i,jstr ,kout)
562 dude=ubar(i,jstr,know)-ubar(i,jstr+1,know)
563
564 IF (lbc(isouth,isubar,ng)%nudging) THEN
565 IF (lnudgem2clm(ng)) THEN
566 obc_out=0.5_r8* &
567 & (clima(ng)%M2nudgcof(i-1,jstr-1)+ &
568 & clima(ng)%M2nudgcof(i ,jstr-1))
569 obc_in =obcfac(ng)*obc_out
570 ELSE
571 obc_out=m2obc_out(ng,isouth)
572 obc_in =m2obc_in(ng,isouth)
573 END IF
574 IF ((dudt*dude).lt.0.0_r8) THEN
575 tau=obc_in
576 ELSE
577 tau=obc_out
578 END IF
579 tau=tau*dt2d
580 END IF
581
582 IF ((dudt*dude).lt.0.0_r8) dudt=0.0_r8
583 IF ((dudt*(grad(i-1,jstr)+ &
584 & grad(i ,jstr))).gt.0.0_r8) THEN
585 dudx=grad(i-1,jstr)
586 ELSE
587 dudx=grad(i ,jstr)
588 END IF
589 cff=dudt/max(dudx*dudx+dude*dude,eps)
590#ifdef RADIATION_2D
591 cx=min(1.0_r8,max(-1.0_r8,cff*dudx))
592#else
593 cx=0.0_r8
594#endif
595 ce=min(1.0_r8,cff*dude)
596#if defined CELERITY_WRITE && defined FORWARD_WRITE
597 boundary(ng)%ubar_south_Cx(i)=cx
598 boundary(ng)%ubar_south_Ce(i)=ce
599 boundary(ng)%ubar_south_C2(i)=cff
600#endif
601 ubar(i,jstr-1,kout)=(1.0_r8-ce)*ubar(i,jstr-1,know)+ &
602 & ce*ubar(i,jstr,know)- &
603 & max(cx,0.0_r8)*grad(i-1,jstr-1)- &
604 & min(cx,0.0_r8)*grad(i ,jstr-1)
605
606 IF (lbc(isouth,isubar,ng)%nudging) THEN
607 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)+ &
608 & tau*(boundary(ng)%ubar_south(i)- &
609 & ubar(i,jstr-1,know))
610 END IF
611#ifdef MASKING
612 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)* &
613 & grid(ng)%umask(i,jstr-1)
614#endif
615 END IF
616 END DO
617!
618! Southern edge, Chapman boundary condition.
619!
620 ELSE IF (lbc(isouth,isubar,ng)%Flather.or. &
621 & lbc(isouth,isubar,ng)%reduced) THEN
622 DO i=istru,iend
623 IF (lbc_apply(ng)%south(i)) THEN
624 cff=dt2d*0.5_r8*(grid(ng)%pn(i-1,jstr)+ &
625 & grid(ng)%pn(i ,jstr))
626 cff1=sqrt(g*0.5_r8*(grid(ng)%h(i-1,jstr)+ &
627 & zeta(i-1,jstr,know)+ &
628 & grid(ng)%h(i ,jstr)+ &
629 & zeta(i ,jstr,know)))
630 ce=cff*cff1
631 cff2=1.0_r8/(1.0_r8+ce)
632 ubar(i,jstr-1,kout)=cff2*(ubar(i,jstr-1,know)+ &
633 & ce*ubar(i,jstr,kout))
634#ifdef MASKING
635 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)* &
636 & grid(ng)%umask(i,jstr-1)
637#endif
638 END IF
639 END DO
640!
641! Southern edge, clamped boundary condition.
642!
643 ELSE IF (lbc(isouth,isubar,ng)%clamped) THEN
644 DO i=istru,iend
645 IF (lbc_apply(ng)%south(i)) THEN
646 ubar(i,jstr-1,kout)=boundary(ng)%ubar_south(i)
647#ifdef MASKING
648 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)* &
649 & grid(ng)%umask(i,jstr-1)
650#endif
651 END IF
652 END DO
653!
654! Southern edge, gradient boundary condition.
655!
656 ELSE IF (lbc(isouth,isubar,ng)%gradient) THEN
657 DO i=istru,iend
658 IF (lbc_apply(ng)%south(i)) THEN
659 ubar(i,jstr-1,kout)=ubar(i,jstr,kout)
660#ifdef MASKING
661 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)* &
662 & grid(ng)%umask(i,jstr-1)
663#endif
664 END IF
665 END DO
666!
667! Southern edge, closed boundary condition: free slip (gamma2=1) or
668! no slip (gamma2=-1).
669!
670 ELSE IF (lbc(isouth,isubar,ng)%closed) THEN
671 IF (ewperiodic(ng)) THEN
672 imin=istru
673 imax=iend
674 ELSE
675 imin=istr
676 imax=iendr
677 END IF
678 DO i=imin,imax
679 IF (lbc_apply(ng)%south(i)) THEN
680 ubar(i,jstr-1,kout)=gamma2(ng)*ubar(i,jstr,kout)
681#ifdef MASKING
682 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)* &
683 & grid(ng)%umask(i,jstr-1)
684#endif
685 END IF
686 END DO
687 END IF
688 END IF
689!
690!-----------------------------------------------------------------------
691! Lateral boundary conditions at the northern edge.
692!-----------------------------------------------------------------------
693!
694 IF (domain(ng)%Northern_Edge(tile)) THEN
695!
696! Northern edge, implicit upstream radiation condition.
697!
698 IF (lbc(inorth,isubar,ng)%radiation) THEN
699 DO i=istru-1,iend
700 grad(i,jend )=ubar(i+1,jend ,know)- &
701 & ubar(i ,jend ,know)
702 grad(i,jend+1)=ubar(i+1,jend+1,know)- &
703 & ubar(i ,jend+1,know)
704 END DO
705 DO i=istru,iend
706 IF (lbc_apply(ng)%north(i)) THEN
707 dudt=ubar(i,jend,know)-ubar(i,jend ,kout)
708 dude=ubar(i,jend,know)-ubar(i,jend-1,know)
709
710 IF (lbc(inorth,isubar,ng)%nudging) THEN
711 IF (lnudgem2clm(ng)) THEN
712 obc_out=0.5_r8* &
713 & (clima(ng)%M2nudgcof(i-1,jend+1)+ &
714 & clima(ng)%M2nudgcof(i ,jend+1))
715 obc_in =obcfac(ng)*obc_out
716 ELSE
717 obc_out=m2obc_out(ng,inorth)
718 obc_in =m2obc_in(ng,inorth)
719 END IF
720 IF ((dudt*dude).lt.0.0_r8) THEN
721 tau=obc_in
722 ELSE
723 tau=obc_out
724 END IF
725 tau=tau*dt2d
726 END IF
727
728 IF ((dudt*dude).lt.0.0_r8) dudt=0.0_r8
729 IF ((dudt*(grad(i-1,jend)+ &
730 & grad(i ,jend))).gt.0.0_r8) THEN
731 dudx=grad(i-1,jend)
732 ELSE
733 dudx=grad(i ,jend)
734 END IF
735 cff=dudt/max(dudx*dudx+dude*dude,eps)
736#ifdef RADIATION_2D
737 cx=min(1.0_r8,max(-1.0_r8,cff*dudx))
738#else
739 cx=0.0_r8
740#endif
741 ce=min(1.0_r8,cff*dude)
742#if defined CELERITY_WRITE && defined FORWARD_WRITE
743 boundary(ng)%ubar_north_Cx(i)=cx
744 boundary(ng)%ubar_north_Ce(i)=ce
745 boundary(ng)%ubar_north_C2(i)=cff
746#endif
747 ubar(i,jend+1,kout)=(1.0_r8-ce)*ubar(i,jend+1,know)+ &
748 & ce*ubar(i,jend,know)- &
749 & max(cx,0.0_r8)*grad(i-1,jend+1)- &
750 & min(cx,0.0_r8)*grad(i ,jend+1)
751
752 IF (lbc(inorth,isubar,ng)%nudging) THEN
753 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)+ &
754 & tau*(boundary(ng)%ubar_north(i)- &
755 & ubar(i,jend+1,know))
756 END IF
757#ifdef MASKING
758 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)* &
759 & grid(ng)%umask(i,jend+1)
760#endif
761 END IF
762 END DO
763!
764! Northern edge, Chapman boundary condition.
765!
766 ELSE IF (lbc(inorth,isubar,ng)%Flather.or. &
767 & lbc(inorth,isubar,ng)%reduced) THEN
768 DO i=istru,iend
769 IF (lbc_apply(ng)%north(i)) THEN
770 cff=dt2d*0.5_r8*(grid(ng)%pn(i-1,jend)+ &
771 & grid(ng)%pn(i ,jend))
772 cff1=sqrt(g*0.5_r8*(grid(ng)%h(i-1,jend)+ &
773 & zeta(i-1,jend,know)+ &
774 & grid(ng)%h(i ,jend)+ &
775 & zeta(i ,jend,know)))
776 ce=cff*cff1
777 cff2=1.0_r8/(1.0_r8+ce)
778 ubar(i,jend+1,kout)=cff2*(ubar(i,jend+1,know)+ &
779 & ce*ubar(i,jend,kout))
780#ifdef MASKING
781 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)* &
782 & grid(ng)%umask(i,jend+1)
783#endif
784 END IF
785 END DO
786!
787! Northern edge, clamped boundary condition.
788!
789 ELSE IF (lbc(inorth,isubar,ng)%clamped) THEN
790 DO i=istru,iend
791 IF (lbc_apply(ng)%north(i)) THEN
792 ubar(i,jend+1,kout)=boundary(ng)%ubar_north(i)
793#ifdef MASKING
794 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)* &
795 & grid(ng)%umask(i,jend+1)
796#endif
797 END IF
798 END DO
799!
800! Northern edge, gradient boundary condition.
801!
802 ELSE IF (lbc(inorth,isubar,ng)%gradient) THEN
803 DO i=istru,iend
804 IF (lbc_apply(ng)%north(i)) THEN
805 ubar(i,jend+1,kout)=ubar(i,jend,kout)
806#ifdef MASKING
807 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)* &
808 & grid(ng)%umask(i,jend+1)
809#endif
810 END IF
811 END DO
812!
813! Northern edge, closed boundary condition: free slip (gamma2=1) or
814! no slip (gamma2=-1).
815!
816 ELSE IF (lbc(inorth,isubar,ng)%closed) THEN
817 IF (ewperiodic(ng)) THEN
818 imin=istru
819 imax=iend
820 ELSE
821 imin=istr
822 imax=iendr
823 END IF
824 DO i=imin,imax
825 IF (lbc_apply(ng)%north(i)) THEN
826 ubar(i,jend+1,kout)=gamma2(ng)*ubar(i,jend,kout)
827#ifdef MASKING
828 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)* &
829 & grid(ng)%umask(i,jend+1)
830#endif
831 END IF
832 END DO
833 END IF
834 END IF
835!
836!-----------------------------------------------------------------------
837! Boundary corners.
838!-----------------------------------------------------------------------
839!
840 IF (.not.(ewperiodic(ng).or.nsperiodic(ng))) THEN
841 IF (domain(ng)%SouthWest_Corner(tile)) THEN
842 IF (lbc_apply(ng)%south(istr ).and. &
843 & lbc_apply(ng)%west (jstr-1)) THEN
844 ubar(istr,jstr-1,kout)=0.5_r8*(ubar(istr+1,jstr-1,kout)+ &
845 & ubar(istr ,jstr ,kout))
846 END IF
847 END IF
848 IF (domain(ng)%SouthEast_Corner(tile)) THEN
849 IF (lbc_apply(ng)%south(iend+1).and. &
850 & lbc_apply(ng)%east (jstr-1)) THEN
851 ubar(iend+1,jstr-1,kout)=0.5_r8*(ubar(iend ,jstr-1,kout)+ &
852 & ubar(iend+1,jstr ,kout))
853 END IF
854 END IF
855 IF (domain(ng)%NorthWest_Corner(tile)) THEN
856 IF (lbc_apply(ng)%north(istr ).and. &
857 & lbc_apply(ng)%west (jend+1)) THEN
858 ubar(istr,jend+1,kout)=0.5_r8*(ubar(istr ,jend ,kout)+ &
859 & ubar(istr+1,jend+1,kout))
860 END IF
861 END IF
862 IF (domain(ng)%NorthEast_Corner(tile)) THEN
863 IF (lbc_apply(ng)%north(iend+1).and. &
864 & lbc_apply(ng)%east (jend+1)) THEN
865 ubar(iend+1,jend+1,kout)=0.5_r8*(ubar(iend+1,jend ,kout)+ &
866 & ubar(iend ,jend+1,kout))
867 END IF
868 END IF
869 END IF
870
871#if defined WET_DRY
872!
873!-----------------------------------------------------------------------
874! Impose wetting and drying conditions.
875!-----------------------------------------------------------------------
876!
877 IF (.not.ewperiodic(ng)) THEN
878 IF (domain(ng)%Western_Edge(tile)) THEN
879 DO j=jstr,jend
880 IF (lbc_apply(ng)%west(j)) THEN
881 cff1=abs(abs(grid(ng)%umask_wet(istr,j))-1.0_r8)
882 cff2=0.5_r8+dsign(0.5_r8,ubar(istr,j,kout))* &
883 & grid(ng)%umask_wet(istr,j)
884 cff=0.5_r8*grid(ng)%umask_wet(istr,j)*cff1+ &
885 & cff2*(1.0_r8-cff1)
886 ubar(istr,j,kout)=ubar(istr,j,kout)*cff
887 END IF
888 END DO
889 END IF
890 IF (domain(ng)%Eastern_Edge(tile)) THEN
891 DO j=jstr,jend
892 IF (lbc_apply(ng)%east(j)) THEN
893 cff1=abs(abs(grid(ng)%umask_wet(iend+1,j))-1.0_r8)
894 cff2=0.5_r8+dsign(0.5_r8,ubar(iend+1,j,kout))* &
895 & grid(ng)%umask_wet(iend+1,j)
896 cff=0.5_r8*grid(ng)%umask_wet(iend+1,j)*cff1+ &
897 & cff2*(1.0_r8-cff1)
898 ubar(iend+1,j,kout)=ubar(iend+1,j,kout)*cff
899 END IF
900 END DO
901 END IF
902 END IF
903
904 IF (.not.nsperiodic(ng)) THEN
905 IF (domain(ng)%Southern_Edge(tile)) THEN
906 DO i=istru,iend
907 IF (lbc_apply(ng)%south(i)) THEN
908 cff1=abs(abs(grid(ng)%umask_wet(i,jstr-1))-1.0_r8)
909 cff2=0.5_r8+dsign(0.5_r8,ubar(i,jstr-1,kout))* &
910 & grid(ng)%umask_wet(i,jstr-1)
911 cff=0.5_r8*grid(ng)%umask_wet(i,jstr-1)*cff1+ &
912 & cff2*(1.0_r8-cff1)
913 ubar(i,jstr-1,kout)=ubar(i,jstr-1,kout)*cff
914 END IF
915 END DO
916 END IF
917 IF (domain(ng)%Northern_Edge(tile)) THEN
918 DO i=istr,iend
919 IF (lbc_apply(ng)%north(i)) THEN
920 cff1=abs(abs(grid(ng)%umask_wet(i,jend+1))-1.0_r8)
921 cff2=0.5_r8+dsign(0.5_r8,ubar(i,jend+1,kout))* &
922 & grid(ng)%umask_wet(i,jend+1)
923 cff=0.5_r8*grid(ng)%umask_wet(i,jend+1)*cff1+ &
924 & cff2*(1.0_r8-cff1)
925 ubar(i,jend+1,kout)=ubar(i,jend+1,kout)*cff
926 END IF
927 END DO
928 END IF
929 END IF
930
931 IF (.not.(ewperiodic(ng).or.nsperiodic(ng))) THEN
932 IF (domain(ng)%SouthWest_Corner(tile)) THEN
933 IF (lbc_apply(ng)%south(istr ).and. &
934 & lbc_apply(ng)%west (jstr-1)) THEN
935 cff1=abs(abs(grid(ng)%umask_wet(istr,jstr-1))-1.0_r8)
936 cff2=0.5_r8+dsign(0.5_r8,ubar(istr,jstr-1,kout))* &
937 & grid(ng)%umask_wet(istr,jstr-1)
938 cff=0.5_r8*grid(ng)%umask_wet(istr,jstr-1)*cff1+ &
939 & cff2*(1.0_r8-cff1)
940 ubar(istr,jstr-1,kout)=ubar(istr,jstr-1,kout)*cff
941 END IF
942 END IF
943 IF (domain(ng)%SouthEast_Corner(tile)) THEN
944 IF (lbc_apply(ng)%south(iend+1).and. &
945 & lbc_apply(ng)%east (jstr-1)) THEN
946 cff1=abs(abs(grid(ng)%umask_wet(iend+1,jstr-1))-1.0_r8)
947 cff2=0.5_r8+dsign(0.5_r8,ubar(iend+1,jstr-1,kout))* &
948 & grid(ng)%umask_wet(iend+1,jstr-1)
949 cff=0.5_r8*grid(ng)%umask_wet(iend+1,jstr-1)*cff1+ &
950 & cff2*(1.0_r8-cff1)
951 ubar(iend+1,jstr-1,kout)=ubar(iend+1,jstr-1,kout)*cff
952 END IF
953 END IF
954 IF (domain(ng)%NorthWest_Corner(tile)) THEN
955 IF (lbc_apply(ng)%north(istr ).and. &
956 & lbc_apply(ng)%west (jend+1)) THEN
957 cff1=abs(abs(grid(ng)%umask_wet(istr,jend+1))-1.0_r8)
958 cff2=0.5_r8+dsign(0.5_r8,ubar(istr,jend+1,kout))* &
959 & grid(ng)%umask_wet(istr,jend+1)
960 cff=0.5_r8*grid(ng)%umask_wet(istr,jend+1)*cff1+ &
961 & cff2*(1.0_r8-cff1)
962 ubar(istr,jend+1,kout)=ubar(istr,jend+1,kout)*cff
963 END IF
964 END IF
965 IF (domain(ng)%NorthEast_Corner(tile)) THEN
966 IF (lbc_apply(ng)%north(iend+1).and. &
967 & lbc_apply(ng)%east (jend+1)) THEN
968 cff1=abs(abs(grid(ng)%umask_wet(iend+1,jend+1))-1.0_r8)
969 cff2=0.5_r8+dsign(0.5_r8,ubar(iend+1,jend+1,kout))* &
970 & grid(ng)%umask_wet(iend+1,jend+1)
971 cff=0.5_r8*grid(ng)%umask_wet(iend+1,jend+1)+cff1+ &
972 & cff2*(1.0_r8-cff1)
973 ubar(iend+1,jend+1,kout)=ubar(iend+1,jend+1,kout)*cff
974 END IF
975 END IF
976 END IF
977#endif
978
979 RETURN
980 END SUBROUTINE u2dbc_tile
981 END MODULE u2dbc_mod
mod_boundary
Definition mod_boundary.F:2
mod_boundary::boundary
type(t_boundary), dimension(:), allocatable boundary
Definition mod_boundary.F:746
mod_boundary::lbc_apply
type(t_apply), dimension(:), allocatable lbc_apply
Definition mod_boundary.F:394
mod_clima
Definition mod_clima.F:2
mod_clima::clima
type(t_clima), dimension(:), allocatable clima
Definition mod_clima.F:153
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::isfsur
integer isfsur
Definition mod_ncparam.F:503
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::lbc
type(t_lbc), dimension(:,:,:), allocatable lbc
Definition mod_param.F:375
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_scalars
Definition mod_scalars.F:2
mod_scalars::lnudgem2clm
logical, dimension(:), allocatable lnudgem2clm
Definition mod_scalars.F:533
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::predictor_2d_step
logical, dimension(:), allocatable predictor_2d_step
Definition mod_scalars.F:245
mod_scalars::obcfac
real(dp), dimension(:), allocatable obcfac
Definition mod_scalars.F:1437
mod_scalars::gamma2
real(r8), dimension(:), allocatable gamma2
Definition mod_scalars.F:743
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::dtfast
real(dp), dimension(:), allocatable dtfast
Definition mod_scalars.F:270
mod_scalars::m2obc_out
real(dp), dimension(:,:), allocatable m2obc_out
Definition mod_scalars.F:1441
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::g
real(dp) g
Definition mod_scalars.F:464
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::m2obc_in
real(dp), dimension(:,:), allocatable m2obc_in
Definition mod_scalars.F:1440
mod_stepping
Definition mod_stepping.F:2
mod_stepping::kstp
integer, dimension(:), allocatable kstp
Definition mod_stepping.F:66
mod_stepping::krhs
integer, dimension(:), allocatable krhs
Definition mod_stepping.F:65
u2dbc_mod
Definition u2dbc_im.F:2
u2dbc_mod::u2dbc_tile
subroutine, public u2dbc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, kout, ubar, vbar, zeta)
Definition u2dbc_im.F:56
u2dbc_mod::u2dbc
subroutine, public u2dbc(ng, tile, kout)
Definition u2dbc_im.F:25