ROMS
Loading...
Searching...
No Matches
set_vbc.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE set_vbc_mod
3#ifdef NONLINEAR
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This module sets vertical boundary conditons for momentum and !
13! tracers. !
14! !
15!=======================================================================
16!
17 implicit none
18!
19 PRIVATE
20 PUBLIC :: set_vbc
21!
22 CONTAINS
23
24# ifdef SOLVE3D
25!
26!***********************************************************************
27 SUBROUTINE set_vbc (ng, tile)
28!***********************************************************************
29!
30 USE mod_param
31 USE mod_grid
32 USE mod_forces
33 USE mod_ocean
34 USE mod_stepping
35!
36! Imported variable declarations.
37!
38 integer, intent(in) :: ng, tile
39!
40! Local variable declarations.
41!
42 character (len=*), parameter :: myfile = &
43 & __FILE__
44!
45# include "tile.h"
46!
47# ifdef PROFILE
48 CALL wclock_on (ng, inlm, 6, __line__, myfile)
49# endif
50 CALL set_vbc_tile (ng, tile, &
51 & lbi, ubi, lbj, ubj, &
52 & imins, imaxs, jmins, jmaxs, &
53 & nrhs(ng), &
54 & grid(ng) % Hz, &
55# if defined UV_LOGDRAG
56 & grid(ng) % ZoBot, &
57# elif defined UV_LDRAG
58 & grid(ng) % rdrag, &
59# elif defined UV_QDRAG
60 & grid(ng) % rdrag2, &
61# endif
62# if !defined BBL_MODEL || defined ICESHELF
63 & grid(ng) % z_r, &
64 & grid(ng) % z_w, &
65# endif
66# ifdef MASKING
67 & grid(ng) % rmask, &
68# endif
69# ifdef WET_DRY
70 & grid(ng) % rmask_wet, &
71# endif
72# if defined ICESHELF
73 & grid(ng) % zice, &
74# endif
75 & ocean(ng) % t, &
76# if !defined BBL_MODEL || defined ICESHELF
77 & ocean(ng) % u, &
78 & ocean(ng) % v, &
79# endif
80# ifdef QCORRECTION
81 & forces(ng) % dqdt, &
82 & forces(ng) % sst, &
83# endif
84# if defined SCORRECTION || defined SRELAXATION
85 & forces(ng) % sss, &
86# endif
87# if defined ICESHELF
88# ifdef SHORTWAVE
89 & forces(ng) % srflx, &
90# endif
91 & forces(ng) % sustr, &
92 & forces(ng) % svstr, &
93# endif
94# ifndef BBL_MODEL
95 & forces(ng) % bustr, &
96 & forces(ng) % bvstr, &
97# endif
98 & forces(ng) % stflux, &
99 & forces(ng) % btflux, &
100 & forces(ng) % stflx, &
101 & forces(ng) % btflx)
102# ifdef PROFILE
103 CALL wclock_off (ng, inlm, 6, __line__, myfile)
104# endif
105!
106 RETURN
107 END SUBROUTINE set_vbc
108!
109!***********************************************************************
110 SUBROUTINE set_vbc_tile (ng, tile, &
111 & LBi, UBi, LBj, UBj, &
112 & IminS, ImaxS, JminS, JmaxS, &
113 & nrhs, &
114 & Hz, &
115# if defined UV_LOGDRAG
116 & ZoBot, &
117# elif defined UV_LDRAG
118 & rdrag, &
119# elif defined UV_QDRAG
120 & rdrag2, &
121# endif
122# if !defined BBL_MODEL || defined ICESHELF
123 & z_r, z_w, &
124# endif
125# if defined MASKING
126 & rmask, &
127# endif
128# ifdef WET_DRY
129 & rmask_wet, &
130# endif
131# if defined ICESHELF
132 & zice, &
133# endif
134 & t, &
135# if !defined BBL_MODEL || defined ICESHELF
136 & u, v, &
137# endif
138# ifdef QCORRECTION
139 & dqdt, sst, &
140# endif
141# if defined SCORRECTION || defined SRELAXATION
142 & sss, &
143# endif
144# if defined ICESHELF
145# ifdef SHORTWAVE
146 & srflx, &
147# endif
148 & sustr, svstr, &
149# endif
150# ifndef BBL_MODEL
151 & bustr, bvstr, &
152# endif
153 & stflux, btflux, &
154 & stflx, btflx)
155!***********************************************************************
156!
157 USE mod_param
158 USE mod_scalars
159!
160 USE bc_2d_mod
161# ifdef DISTRIBUTE
162 USE mp_exchange_mod, ONLY : mp_exchange2d
163# endif
164!
165! Imported variable declarations.
166!
167 integer, intent(in) :: ng, tile
168 integer, intent(in) :: LBi, UBi, LBj, UBj
169 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
170 integer, intent(in) :: nrhs
171!
172# ifdef ASSUMED_SHAPE
173 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
174# if defined UV_LOGDRAG
175 real(r8), intent(in) :: ZoBot(LBi:,LBj:)
176# elif defined UV_LDRAG
177 real(r8), intent(in) :: rdrag(LBi:,LBj:)
178# elif defined UV_QDRAG
179 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
180# endif
181# if !defined BBL_MODEL || defined ICESHELF
182 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
183 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
184# endif
185# if defined MASKING
186 real(r8), intent(in) :: rmask(LBi:,LBj:)
187# endif
188# ifdef WET_DRY
189 real(r8), intent(in) :: rmask_wet(LBi:,LBj:)
190# endif
191# if defined ICESHELF
192 real(r8), intent(in) :: zice(LBi:,LBj:)
193# endif
194 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
195# if !defined BBL_MODEL || defined ICESHELF
196 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
197 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
198# endif
199# ifdef QCORRECTION
200 real(r8), intent(in) :: dqdt(LBi:,LBj:)
201 real(r8), intent(in) :: sst(LBi:,LBj:)
202# endif
203# if defined SCORRECTION || defined SRELAXATION
204 real(r8), intent(in) :: sss(LBi:,LBj:)
205# endif
206 real(r8), intent(in) :: stflux(LBi:,LBj:,:)
207 real(r8), intent(in) :: btflux(LBi:,LBj:,:)
208# if defined ICESHELF
209# ifdef SHORTWAVE
210 real(r8), intent(inout) :: srflx(LBi:,LBj:)
211# endif
212 real(r8), intent(inout) :: sustr(LBi:,LBj:)
213 real(r8), intent(inout) :: svstr(LBi:,LBj:)
214# endif
215# ifndef BBL_MODEL
216 real(r8), intent(inout) :: bustr(LBi:,LBj:)
217 real(r8), intent(inout) :: bvstr(LBi:,LBj:)
218# endif
219 real(r8), intent(inout) :: stflx(LBi:,LBj:,:)
220 real(r8), intent(inout) :: btflx(LBi:,LBj:,:)
221# else
222 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
223# if defined UV_LOGDRAG
224 real(r8), intent(in) :: ZoBot(LBi:UBi,LBj:UBj)
225# elif defined UV_LDRAG
226 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
227# elif defined UV_QDRAG
228 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
229# endif
230# if !defined BBL_MODEL || defined ICESHELF
231 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
232 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
233# endif
234# if defined MASKING
235 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
236# endif
237# ifdef WET_DRY
238 real(r8), intent(in) :: rmask_wet(LBi:UBi,LBj:UBj)
239# endif
240# if defined ICESHELF
241 real(r8), intent(in) :: zice(LBi:UBi,LBj:UBj)
242# endif
243 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
244# if !defined BBL_MODEL || defined ICESHELF
245 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
246 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
247# endif
248# ifdef QCORRECTION
249 real(r8), intent(in) :: dqdt(LBi:UBi,LBj:UBj)
250 real(r8), intent(in) :: sst(LBi:UBi,LBj:UBj)
251# endif
252# if defined SCORRECTION || defined SRELAXATION
253 real(r8), intent(in) :: sss(LBi:UBi,LBj:UBj)
254# endif
255 real(r8), intent(in) :: stflux(LBi:UBi,LBj:UBj,NT(ng))
256 real(r8), intent(in) :: btflux(LBi:UBi,LBj:UBj,NT(ng))
257# if defined ICESHELF
258# ifdef SHORTWAVE
259 real(r8), intent(inout) :: srflx(LBi:UBi,LBj:UBj)
260# endif
261 real(r8), intent(inout) :: sustr(LBi:UBi,LBj:UBj)
262 real(r8), intent(inout) :: svstr(LBi:UBi,LBj:UBj)
263# endif
264# ifndef BBL_MODEL
265 real(r8), intent(inout) :: bustr(LBi:UBi,LBj:UBj)
266 real(r8), intent(inout) :: bvstr(LBi:UBi,LBj:UBj)
267# endif
268 real(r8), intent(inout) :: stflx(LBi:UBi,LBj:UBj,NT(ng))
269 real(r8), intent(inout) :: btflx(LBi:UBi,LBj:UBj,NT(ng))
270# endif
271!
272! Local variable declarations.
273!
274 integer :: i, j, itrc
275
276 real(r8) :: EmP
277# if !defined BBL_MODEL || defined ICESHELF || \
278 defined limit_stflx_cooling
279 real(r8) :: cff, cff1, cff2, cff3
280# endif
281
282# if (!defined BBL_MODEL || defined ICESHELF) && defined UV_LOGDRAG
283 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wrk
284# endif
285
286# include "set_bounds.h"
287!
288!-----------------------------------------------------------------------
289! Load surface and bottom net heat flux (degC m/s) into state variables
290! "stflx" and "btflx".
291!
292! Notice that the forcing net heat flux stflux(:,:,itemp) is processed
293! elsewhere from data, coupling, bulk flux parameterization,
294! or analytical formulas.
295!
296! During model coupling, we need to make sure that this forcing is
297! unaltered during the coupling interval when ROMS timestep size is
298! smaller. Notice that further manipulations to state variable
299! stflx(:,:,itemp) are allowed below.
300!-----------------------------------------------------------------------
301!
302 DO j=jstrr,jendr
303 DO i=istrr,iendr
304 stflx(i,j,itemp)=stflux(i,j,itemp)
305 btflx(i,j,itemp)=btflux(i,j,itemp)
306# ifdef WET_DRY
307 stflx(i,j,itemp)=stflx(i,j,itemp)*rmask_wet(i,j)
308 btflx(i,j,itemp)=btflx(i,j,itemp)*rmask_wet(i,j)
309# endif
310 END DO
311 END DO
312
313# ifdef QCORRECTION
314!
315!-----------------------------------------------------------------------
316! Add in flux correction to surface net heat flux (degC m/s).
317!-----------------------------------------------------------------------
318!
319! Add in net heat flux correction.
320!
321 DO j=jstrr,jendr
322 DO i=istrr,iendr
323 stflx(i,j,itemp)=stflx(i,j,itemp)+ &
324 & dqdt(i,j)*(t(i,j,n(ng),nrhs,itemp)-sst(i,j))
325# ifdef WET_DRY
326 stflx(i,j,itemp)=stflx(i,j,itemp)*rmask_wet(i,j)
327# endif
328 END DO
329 END DO
330# endif
331
332# ifdef LIMIT_STFLX_COOLING
333!
334!-----------------------------------------------------------------------
335! If net heat flux is cooling and SST is at freezing point or below
336! then suppress further cooling. Note: stflx sign convention is that
337! positive means heating the ocean (J Wilkin).
338!-----------------------------------------------------------------------
339!
340! Below the surface heat flux stflx(:,:,itemp) is ZERO if cooling AND
341! the SST is cooler than the threshold. The value is retained if
342! warming.
343!
344! cff3 = 0 if SST warmer than threshold (cff1) - change nothing
345! cff3 = 1 if SST colder than threshold (cff1)
346!
347! 0.5*(cff2-ABS(cff2)) = 0 if flux is warming
348! = stflx(:,:,itemp) if flux is cooling
349!
350 cff1=-2.0_r8 ! nominal SST threshold to cease cooling
351 DO j=jstrr,jendr
352 DO i=istrr,iendr
353 cff2=stflx(i,j,itemp)
354 cff3=0.5_r8*(1.0_r8+sign(1.0_r8,cff1-t(i,j,n(ng),nrhs,itemp)))
355 stflx(i,j,itemp)=cff2-cff3*0.5_r8*(cff2-abs(cff2))
356# ifdef WET_DRY
357 stflx(i,j,itemp)=stflx(i,j,itemp)*rmask_wet(i,j)
358# endif
359 END DO
360 END DO
361# endif
362
363# ifdef SALINITY
364!
365!-----------------------------------------------------------------------
366! Multiply freshwater fluxes with surface and bottom salinity.
367!
368! If appropriate, apply correction. Notice that input stflux(:,:,isalt)
369! is the net freshwater flux (E-P; m/s) from data, coupling, bulk flux
370! parameterization, or analytical formula. It has not been multiplied
371! by the surface and bottom salinity.
372!-----------------------------------------------------------------------
373!
374 DO j=jstrr,jendr
375 DO i=istrr,iendr
376 emp=stflux(i,j,isalt)
377# if defined SCORRECTION
378 stflx(i,j,isalt)=emp*t(i,j,n(ng),nrhs,isalt)- &
379 & tnudg(isalt,ng)*hz(i,j,n(ng))* &
380 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))
381# ifdef WET_DRY
382 stflx(i,j,isalt) = rmask_wet(i,j)*stflx(i,j,isalt)
383# elif defined MASKING
384 stflx(i,j,isalt) = rmask(i,j)*stflx(i,j,isalt)
385# endif
386# elif defined SRELAXATION
387 stflx(i,j,isalt)=-tnudg(isalt,ng)*hz(i,j,n(ng))* &
388 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))
389# ifdef WET_DRY
390 stflx(i,j,isalt) = rmask_wet(i,j)*stflx(i,j,isalt)
391# elif defined MASKING
392 stflx(i,j,isalt) = rmask(i,j)*stflx(i,j,isalt)
393# endif
394# else
395 stflx(i,j,isalt)=emp*t(i,j,n(ng),nrhs,isalt)
396# ifdef WET_DRY
397 stflx(i,j,isalt) = rmask_wet(i,j)*stflx(i,j,isalt)
398# elif defined MASKING
399 stflx(i,j,isalt) = rmask(i,j)*stflx(i,j,isalt)
400# endif
401# endif
402 btflx(i,j,isalt)=btflx(i,j,isalt)*t(i,j,1,nrhs,isalt)
403 END DO
404 END DO
405# endif
406
407# if defined BIOLOGY || defined SEDIMENT || defined T_PASSIVE
408!
409!-----------------------------------------------------------------------
410! Load surface and bottom passive tracer fluxes (T m/s).
411!-----------------------------------------------------------------------
412!
413 DO itrc=nat+1,nt(ng)
414 DO j=jstrr,jendr
415 DO i=istrr,iendr
416 stflx(i,j,itrc)=stflux(i,j,itrc)
417 btflx(i,j,itrc)=btflux(i,j,itrc)
418 END DO
419 END DO
420 END DO
421# endif
422
423# ifdef ICESHELF
424!
425!-----------------------------------------------------------------------
426! If ice shelf cavities, zero out for now the surface tracer flux
427! over the ice.
428!-----------------------------------------------------------------------
429!
430 DO itrc=1,nt(ng)
431 DO j=jstrr,jendr
432 DO i=istrr,iendr
433 IF (zice(i,j).ne.0.0_r8) THEN
434 stflx(i,j,itrc)=0.0_r8
435 END IF
436 END DO
437 END DO
438 END DO
439# ifdef SHORTWAVE
440 DO j=jstrr,jendr
441 DO i=istrr,iendr
442 IF (zice(i,j).ne.0.0_r8) THEN
443 srflx(i,j)=0.0_r8
444 END IF
445 END DO
446 END DO
447# endif
448!
449!-----------------------------------------------------------------------
450! If ice shelf cavities, replace surface wind stress with ice shelf
451! cavity stress (m2/s2).
452!-----------------------------------------------------------------------
453
454# if defined UV_LOGDRAG
455!
456! Set logarithmic ice shelf cavity stress.
457!
458 DO j=jstrv-1,jend
459 DO i=istru-1,iend
460 cff1=1.0_r8/log((z_w(i,j,n(ng))-z_r(i,j,n(ng)))/zobot(i,j))
461 cff2=vonkar*vonkar*cff1*cff1
462 wrk(i,j)=min(cdb_max,max(cdb_min,cff2))
463 END DO
464 END DO
465 DO j=jstr,jend
466 DO i=istru,iend
467 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
468 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
469 & v(i ,j+1,n(ng),nrhs)+ &
470 & v(i-1,j ,n(ng),nrhs)+ &
471 & v(i-1,j+1,n(ng),nrhs))
472 cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
473 sustr(i,j)=-0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
474 & u(i,j,n(ng),nrhs)*cff2
475 END IF
476 END DO
477 END DO
478 DO j=jstrv,jend
479 DO i=istr,iend
480 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
481 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
482 & u(i+1,j ,n(ng),nrhs)+ &
483 & u(i ,j-1,n(ng),nrhs)+ &
484 & u(i+1,j-1,n(ng),nrhs))
485 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
486 svstr(i,j)=-0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
487 & v(i,j,n(ng),nrhs)*cff2
488 END IF
489 END DO
490 END DO
491# elif defined UV_QDRAG
492!
493! Set quadratic ice shelf cavity stress.
494!
495 DO j=jstr,jend
496 DO i=istru,iend
497 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
498 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
499 & v(i ,j+1,n(ng),nrhs)+ &
500 & v(i-1,j ,n(ng),nrhs)+ &
501 & v(i-1,j+1,n(ng),nrhs))
502 cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
503 sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
504 & u(i,j,n(ng),nrhs)*cff2
505 END IF
506 END DO
507 END DO
508 DO j=jstrv,jend
509 DO i=istr,iend
510 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
511 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
512 & u(i+1,j ,n(ng),nrhs)+ &
513 & u(i ,j-1,n(ng),nrhs)+ &
514 & u(i+1,j-1,n(ng),nrhs))
515 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
516 svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
517 & v(i,j,n(ng),nrhs)*cff2
518 END IF
519 END DO
520 END DO
521# elif defined UV_LDRAG
522!
523! Set linear ice shelf cavity stress.
524!
525 DO j=jstr,jend
526 DO i=istru,iend
527 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
528 sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
529 & u(i,j,n(ng),nrhs)
530 END IF
531 END DO
532 END DO
533 DO j=jstrv,jend
534 DO i=istr,iend
535 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
536 svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
537 & v(i,j,n(ng),nrhs)
538 END IF
539 END DO
540 END DO
541# else
542 DO j=jstr,jend
543 DO i=istru,iend
544 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
545 sustr(i,j)=0.0_r8
546 END IF
547 END DO
548 END DO
549 DO j=jstrv,jend
550 DO i=istr,iend
551 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
552 svstr(i,j)=0.0_r8
553 END IF
554 END DO
555 END DO
556# endif
557!
558! Apply periodic or gradient boundary conditions for output
559! purposes only.
560!
561 CALL bc_u2d_tile (ng, tile, &
562 & lbi, ubi, lbj, ubj, &
563 & sustr)
564 CALL bc_v2d_tile (ng, tile, &
565 & lbi, ubi, lbj, ubj, &
566 & svstr)
567# ifdef DISTRIBUTE
568 CALL mp_exchange2d (ng, tile, inlm, 2, &
569 & lbi, ubi, lbj, ubj, &
570 & nghostpoints, &
571 & ewperiodic(ng), nsperiodic(ng), &
572 & sustr, svstr)
573# endif
574# endif
575
576# ifndef BBL_MODEL
577!
578!-----------------------------------------------------------------------
579! Set kinematic bottom momentum flux (m2/s2).
580!-----------------------------------------------------------------------
581
582# ifdef LIMIT_BSTRESS
583!
584! Set limiting factor for bottom stress. The bottom stress is adjusted
585! to not change the direction of momentum. It only should slow down
586! to zero. The value of 0.75 is arbitrary limitation assigment.
587!
588 cff=0.75_r8/dt(ng)
589# endif
590
591# if defined UV_LOGDRAG
592!
593! Set logarithmic bottom stress.
594!
595 DO j=jstrv-1,jend
596 DO i=istru-1,iend
597 cff1=1.0_r8/log((z_r(i,j,1)-z_w(i,j,0))/zobot(i,j))
598 cff2=vonkar*vonkar*cff1*cff1
599 wrk(i,j)=min(cdb_max,max(cdb_min,cff2))
600 END DO
601 END DO
602 DO j=jstr,jend
603 DO i=istru,iend
604 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
605 & v(i ,j+1,1,nrhs)+ &
606 & v(i-1,j ,1,nrhs)+ &
607 & v(i-1,j+1,1,nrhs))
608 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
609 bustr(i,j)=0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
610 & u(i,j,1,nrhs)*cff2
611# ifdef LIMIT_BSTRESS
612 cff3=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
613 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
614 & min(abs(bustr(i,j)), &
615 & abs(u(i,j,1,nrhs))*cff3)
616# endif
617 END DO
618 END DO
619 DO j=jstrv,jend
620 DO i=istr,iend
621 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
622 & u(i+1,j ,1,nrhs)+ &
623 & u(i ,j-1,1,nrhs)+ &
624 & u(i+1,j-1,1,nrhs))
625 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
626 bvstr(i,j)=0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
627 & v(i,j,1,nrhs)*cff2
628# ifdef LIMIT_BSTRESS
629 cff3=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
630 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
631 & min(abs(bvstr(i,j)), &
632 & abs(v(i,j,1,nrhs))*cff3)
633# endif
634 END DO
635 END DO
636# elif defined UV_QDRAG
637!
638! Set quadratic bottom stress.
639!
640 DO j=jstr,jend
641 DO i=istru,iend
642 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
643 & v(i ,j+1,1,nrhs)+ &
644 & v(i-1,j ,1,nrhs)+ &
645 & v(i-1,j+1,1,nrhs))
646 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
647 bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
648 & u(i,j,1,nrhs)*cff2
649# ifdef LIMIT_BSTRESS
650 cff3=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
651 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
652 & min(abs(bustr(i,j)), &
653 & abs(u(i,j,1,nrhs))*cff3)
654# endif
655 END DO
656 END DO
657 DO j=jstrv,jend
658 DO i=istr,iend
659 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
660 & u(i+1,j ,1,nrhs)+ &
661 & u(i ,j-1,1,nrhs)+ &
662 & u(i+1,j-1,1,nrhs))
663 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
664 bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
665 & v(i,j,1,nrhs)*cff2
666# ifdef LIMIT_BSTRESS
667 cff3=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
668 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
669 & min(abs(bvstr(i,j)), &
670 & abs(v(i,j,1,nrhs))*cff3)
671# endif
672 END DO
673 END DO
674# elif defined UV_LDRAG
675!
676! Set linear bottom stress.
677!
678 DO j=jstr,jend
679 DO i=istru,iend
680 bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
681 & u(i,j,1,nrhs)
682# ifdef LIMIT_BSTRESS
683 cff1=cff*0.5_r8*(hz(i-1,j,1)+hz(i,j,1))
684 bustr(i,j)=sign(1.0_r8, bustr(i,j))* &
685 & min(abs(bustr(i,j)), &
686 & abs(u(i,j,1,nrhs))*cff1)
687# endif
688 END DO
689 END DO
690 DO j=jstrv,jend
691 DO i=istr,iend
692 bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
693 & v(i,j,1,nrhs)
694# ifdef LIMIT_BSTRESS
695 cff1=cff*0.5_r8*(hz(i,j-1,1)+hz(i,j,1))
696 bvstr(i,j)=sign(1.0_r8, bvstr(i,j))* &
697 & min(abs(bvstr(i,j)), &
698 & abs(v(i,j,1,nrhs))*cff1)
699# endif
700 END DO
701 END DO
702# endif
703!
704! Apply boundary conditions.
705!
706 CALL bc_u2d_tile (ng, tile, &
707 & lbi, ubi, lbj, ubj, &
708 & bustr)
709 CALL bc_v2d_tile (ng, tile, &
710 & lbi, ubi, lbj, ubj, &
711 & bvstr)
712# ifdef DISTRIBUTE
713 CALL mp_exchange2d (ng, tile, inlm, 2, &
714 & lbi, ubi, lbj, ubj, &
715 & nghostpoints, &
716 & ewperiodic(ng), nsperiodic(ng), &
717 & bustr, bvstr)
718# endif
719# endif
720!
721 RETURN
722 END SUBROUTINE set_vbc_tile
723
724# else
725
726!
727!***********************************************************************
728 SUBROUTINE set_vbc (ng, tile)
729!***********************************************************************
730!
731 USE mod_param
732 USE mod_grid
733 USE mod_forces
734 USE mod_ocean
735 USE mod_stepping
736!
737! Imported variable declarations.
738!
739 integer, intent(in) :: ng, tile
740!
741! Local variable declarations.
742!
743 character (len=*), parameter :: MyFile = &
744 & __FILE__
745!
746# include "tile.h"
747!
748# ifdef PROFILE
749 CALL wclock_on (ng, inlm, 6, __line__, myfile)
750# endif
751 CALL set_vbc_tile (ng, tile, &
752 & lbi, ubi, lbj, ubj, &
753 & imins, imaxs, jmins, jmaxs, &
754 & krhs(ng), kstp(ng), knew(ng), &
755# if defined UV_LDRAG
756 & grid(ng) % rdrag, &
757# elif defined UV_QDRAG
758 & grid(ng) % rdrag2, &
759# endif
760 & ocean(ng) % ubar, &
761 & ocean(ng) % vbar, &
762 & forces(ng) % bustr, &
763 & forces(ng) % bvstr)
764# ifdef PROFILE
765 CALL wclock_off (ng, inlm, 6, __line__, myfile)
766# endif
767!
768 RETURN
769 END SUBROUTINE set_vbc
770!
771!***********************************************************************
772 SUBROUTINE set_vbc_tile (ng, tile, &
773 & LBi, UBi, LBj, UBj, &
774 & IminS, ImaxS, JminS, JmaxS, &
775 & krhs, kstp, knew, &
776# if defined UV_LDRAG
777 & rdrag, &
778# elif defined UV_QDRAG
779 & rdrag2, &
780# endif
781 & ubar, vbar, bustr, bvstr)
782!***********************************************************************
783!
784 USE mod_param
785 USE mod_scalars
786!
787 USE bc_2d_mod
788# ifdef DISTRIBUTE
789 USE mp_exchange_mod, ONLY : mp_exchange2d
790# endif
791!
792! Imported variable declarations.
793!
794 integer, intent(in) :: ng, tile
795 integer, intent(in) :: LBi, UBi, LBj, UBj
796 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
797 integer, intent(in) :: krhs, kstp, knew
798!
799# ifdef ASSUMED_SHAPE
800# ifdef UV_LDRAG
801 real(r8), intent(in) :: rdrag(LBi:,LBj:)
802# endif
803# ifdef UV_QDRAG
804 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
805# endif
806 real(r8), intent(in) :: ubar(LBi:,LBj:,:)
807 real(r8), intent(in) :: vbar(LBi:,LBj:,:)
808 real(r8), intent(inout) :: bustr(LBi:,LBj:)
809 real(r8), intent(inout) :: bvstr(LBi:,LBj:)
810# else
811# ifdef UV_LDRAG
812 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
813# endif
814# ifdef UV_QDRAG
815 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
816# endif
817 real(r8), intent(in) :: ubar(LBi:UBi,LBj:UBj,:)
818 real(r8), intent(in) :: vbar(LBi:UBi,LBj:UBj,:)
819 real(r8), intent(inout) :: bustr(LBi:UBi,LBj:UBj)
820 real(r8), intent(inout) :: bvstr(LBi:UBi,LBj:UBj)
821# endif
822!
823! Local variable declarations.
824!
825 integer :: i, j
826
827 real(r8) :: cff1, cff2
828
829# include "set_bounds.h"
830!
831!-----------------------------------------------------------------------
832! Set kinematic barotropic bottom momentum stress (m2/s2).
833!-----------------------------------------------------------------------
834
835# if defined UV_LDRAG
836!
837! Set linear bottom stress.
838!
839 DO j=jstr,jend
840 DO i=istru,iend
841 bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
842 & ubar(i,j,krhs)
843 END DO
844 END DO
845 DO j=jstrv,jend
846 DO i=istr,iend
847 bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
848 & vbar(i,j,krhs)
849 END DO
850 END DO
851# elif defined UV_QDRAG
852!
853! Set quadratic bottom stress.
854!
855 DO j=jstr,jend
856 DO i=istru,iend
857 cff1=0.25_r8*(vbar(i ,j ,krhs)+ &
858 & vbar(i ,j+1,krhs)+ &
859 & vbar(i-1,j ,krhs)+ &
860 & vbar(i-1,j+1,krhs))
861 cff2=sqrt(ubar(i,j,krhs)*ubar(i,j,krhs)+cff1*cff1)
862 bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
863 & ubar(i,j,krhs)*cff2
864 END DO
865 END DO
866 DO j=jstrv,jend
867 DO i=istr,iend
868 cff1=0.25_r8*(ubar(i ,j ,krhs)+ &
869 & ubar(i+1,j ,krhs)+ &
870 & ubar(i ,j-1,krhs)+ &
871 & ubar(i+1,j-1,krhs))
872 cff2=sqrt(cff1*cff1+vbar(i,j,krhs)*vbar(i,j,krhs))
873 bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
874 & vbar(i,j,krhs)*cff2
875 END DO
876 END DO
877# endif
878!
879! Apply boundary conditions.
880!
881 CALL bc_u2d_tile (ng, tile, &
882 & lbi, ubi, lbj, ubj, &
883 & bustr)
884 CALL bc_v2d_tile (ng, tile, &
885 & lbi, ubi, lbj, ubj, &
886 & bvstr)
887
888# ifdef DISTRIBUTE
889 CALL mp_exchange2d (ng, tile, inlm, 2, &
890 & lbi, ubi, lbj, ubj, &
891 & nghostpoints, &
892 & ewperiodic(ng), nsperiodic(ng), &
893 & bustr, bvstr)
894# endif
895!
896 RETURN
897 END SUBROUTINE set_vbc_tile
898# endif
899#endif
900 END MODULE set_vbc_mod
bc_2d_mod
Definition bc_2d.F:2
bc_2d_mod::bc_v2d_tile
subroutine bc_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition bc_2d.F:345
bc_2d_mod::bc_u2d_tile
subroutine bc_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition bc_2d.F:167
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_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::nat
integer nat
Definition mod_param.F:499
mod_param::inlm
integer, parameter inlm
Definition mod_param.F:662
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_scalars
Definition mod_scalars.F:2
mod_scalars::cdb_min
real(dp) cdb_min
Definition mod_scalars.F:772
mod_scalars::vonkar
real(dp) vonkar
Definition mod_scalars.F:469
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::tnudg
real(dp), dimension(:,:), allocatable tnudg
Definition mod_scalars.F:1455
mod_scalars::isalt
integer isalt
Definition mod_scalars.F:127
mod_scalars::itemp
integer itemp
Definition mod_scalars.F:126
mod_scalars::cdb_max
real(dp) cdb_max
Definition mod_scalars.F:773
mod_stepping
Definition mod_stepping.F:2
mod_stepping::kstp
integer, dimension(:), allocatable kstp
Definition mod_stepping.F:66
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
mod_stepping::nrhs
integer, dimension(:), allocatable nrhs
Definition mod_stepping.F:70
mod_stepping::krhs
integer, dimension(:), allocatable krhs
Definition mod_stepping.F:65
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::mp_exchange2d
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:294
set_vbc_mod
Definition set_vbc.F:2
set_vbc_mod::set_vbc
subroutine, public set_vbc(ng, tile)
Definition set_vbc.F:28
set_vbc_mod::set_vbc_tile
subroutine set_vbc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nrhs, hz, zobot, z_r, z_w, rmask, rmask_wet, zice, t, u, v, dqdt, sst, sss, sustr, svstr, stflux, btflux, stflx, btflx)
Definition set_vbc.F:155
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3