ROMS
Loading...
Searching...
No Matches
rp_set_vbc.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE rp_set_vbc_mod
3#ifdef TL_IOMS
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This module sets vertical boundary conditions for representers !
13! tangent linear momentum and tracers. !
14! !
15! BASIC STATE variables needed: stflx, dqdt, t, sss, btflx, u, v, !
16! z_r !
17! !
18! NOTE: stflx and btflx will be over written. !
19! !
20!=======================================================================
21!
22 implicit none
23!
24 PRIVATE
25 PUBLIC :: rp_set_vbc
26!
27 CONTAINS
28
29# ifdef SOLVE3D
30!
31!***********************************************************************
32 SUBROUTINE rp_set_vbc (ng, tile)
33!***********************************************************************
34!
35 USE mod_param
36 USE mod_grid
37 USE mod_forces
38 USE mod_ocean
39 USE mod_stepping
40!
41! Imported variable declarations.
42!
43 integer, intent(in) :: ng, tile
44!
45! Local variable declarations.
46!
47 character (len=*), parameter :: myfile = &
48 & __FILE__
49!
50# include "tile.h"
51!
52# ifdef PROFILE
53 CALL wclock_on (ng, irpm, 6, __line__, myfile)
54# endif
55 CALL rp_set_vbc_tile (ng, tile, &
56 & lbi, ubi, lbj, ubj, &
57 & imins, imaxs, jmins, jmaxs, &
58 & nrhs(ng), &
59 & grid(ng) % Hz, &
60 & grid(ng) % tl_Hz, &
61# if defined UV_LOGDRAG
62 & grid(ng) % ZoBot, &
63# elif defined UV_LDRAG
64 & grid(ng) % rdrag, &
65# elif defined UV_QDRAG
66 & grid(ng) % rdrag2, &
67# endif
68# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
69 & grid(ng) % z_r, &
70 & grid(ng) % z_w, &
71 & grid(ng) % tl_z_r, &
72 & grid(ng) % tl_z_w, &
73# endif
74# if defined ICESHELF
75 & grid(ng) % zice, &
76# endif
77 & ocean(ng) % t, &
78 & ocean(ng) % tl_t, &
79# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
80 & ocean(ng) % u, &
81 & ocean(ng) % v, &
82 & ocean(ng) % tl_u, &
83 & ocean(ng) % tl_v, &
84# endif
85# ifdef QCORRECTION
86 & forces(ng) % dqdt, &
87 & forces(ng) % sst, &
88# endif
89# if defined SCORRECTION || defined SRELAXATION
90 & forces(ng) % sss, &
91# endif
92# if defined ICESHELF
93# ifdef SHORTWAVE
94 & forces(ng) % srflx, &
95# endif
96 & forces(ng) % sustr, &
97 & forces(ng) % svstr, &
98 & forces(ng) % tl_sustr, &
99 & forces(ng) % tl_svstr, &
100# endif
101# ifndef BBL_MODEL_NOT_YET
102 & forces(ng) % bustr, &
103 & forces(ng) % bvstr, &
104 & forces(ng) % tl_bustr, &
105 & forces(ng) % tl_bvstr, &
106# endif
107 & forces(ng) % stflux, &
108 & forces(ng) % btflux, &
109 & forces(ng) % stflx, &
110 & forces(ng) % btflx, &
111 & forces(ng) % tl_stflx, &
112 & forces(ng) % tl_btflx)
113# ifdef PROFILE
114 CALL wclock_off (ng, irpm, 6, __line__, myfile)
115# endif
116!
117 RETURN
118 END SUBROUTINE rp_set_vbc
119!
120!***********************************************************************
121 SUBROUTINE rp_set_vbc_tile (ng, tile, &
122 & LBi, UBi, LBj, UBj, &
123 & IminS, ImaxS, JminS, JmaxS, &
124 & nrhs, &
125 & Hz, tl_Hz, &
126# if defined UV_LOGDRAG
127 & ZoBot, &
128# elif defined UV_LDRAG
129 & rdrag, &
130# elif defined UV_QDRAG
131 & rdrag2, &
132# endif
133# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
134 & z_r, z_w, &
135 & tl_z_r, tl_z_w, &
136# endif
137# if defined ICESHELF
138 & zice, &
139# endif
140 & t, tl_t, &
141# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
142 & u, v, &
143 & tl_u, tl_v, &
144# endif
145# ifdef QCORRECTION
146 & dqdt, sst, &
147# endif
148# if defined SCORRECTION || defined SRELAXATION
149 & sss, &
150# endif
151# if defined ICESHELF
152# ifdef SHORTWAVE
153 & srflx, &
154# endif
155 & sustr, svstr, &
156 & tl_sustr, tl_svstr, &
157# endif
158# ifndef BBL_MODEL_NOT_YET
159 & bustr, bvstr, &
160 & tl_bustr, tl_bvstr, &
161# endif
162 & stflux, btflux, &
163 & stflx, btflx, &
164 & tl_stflx, tl_btflx)
165!***********************************************************************
166!
167 USE mod_param
168 USE mod_scalars
169!
170 USE bc_2d_mod
171# ifdef DISTRIBUTE
172 USE mp_exchange_mod, ONLY : mp_exchange2d
173# endif
174!
175! Imported variable declarations.
176!
177 integer, intent(in) :: ng, tile
178 integer, intent(in) :: LBi, UBi, LBj, UBj
179 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
180 integer, intent(in) :: nrhs
181!
182# ifdef ASSUMED_SHAPE
183 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
184 real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
185# if defined UV_LOGDRAG
186 real(r8), intent(in) :: ZoBot(LBi:,LBj:)
187# elif defined UV_LDRAG
188 real(r8), intent(in) :: rdrag(LBi:,LBj:)
189# elif defined UV_QDRAG
190 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
191# endif
192# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
193 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
194 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
195 real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
196 real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
197# endif
198# if defined ICESHELF
199 real(r8), intent(in) :: zice(LBi:,LBj:)
200# endif
201 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
202 real(r8), intent(in) :: tl_t(LBi:,LBj:,:,:,:)
203# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
204 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
205 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
206 real(r8), intent(in) :: tl_u(LBi:,LBj:,:,:)
207 real(r8), intent(in) :: tl_v(LBi:,LBj:,:,:)
208# endif
209# ifdef QCORRECTION
210 real(r8), intent(in) :: dqdt(LBi:,LBj:)
211 real(r8), intent(in) :: sst(LBi:,LBj:)
212# endif
213# if defined SCORRECTION || defined SRELAXATION
214 real(r8), intent(in) :: sss(LBi:,LBj:)
215# endif
216 real(r8), intent(in) :: stflux(LBi:,LBj:,:)
217 real(r8), intent(in) :: btflux(LBi:,LBj:,:)
218# if defined ICESHELF
219# ifdef SHORTWAVE
220 real(r8), intent(inout) :: srflx(LBi:,LBj:)
221# endif
222 real(r8), intent(inout) :: sustr(LBi:,LBj:)
223 real(r8), intent(inout) :: svstr(LBi:,LBj:)
224 real(r8), intent(inout) :: tl_sustr(LBi:,LBj:)
225 real(r8), intent(inout) :: tl_svstr(LBi:,LBj:)
226# endif
227# ifndef BBL_MODEL_NOT_YET
228 real(r8), intent(inout) :: bustr(LBi:,LBj:)
229 real(r8), intent(inout) :: bvstr(LBi:,LBj:)
230 real(r8), intent(inout) :: tl_bustr(LBi:,LBj:)
231 real(r8), intent(inout) :: tl_bvstr(LBi:,LBj:)
232# endif
233 real(r8), intent(inout) :: stflx(LBi:,LBj:,:)
234 real(r8), intent(inout) :: btflx(LBi:,LBj:,:)
235 real(r8), intent(inout) :: tl_stflx(LBi:,LBj:,:)
236 real(r8), intent(inout) :: tl_btflx(LBi:,LBj:,:)
237# else
238 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
239 real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng))
240# if defined UV_LOGDRAG
241 real(r8), intent(in) :: ZoBot(LBi:UBi,LBj:UBj)
242# elif defined UV_LDRAG
243 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
244# elif defined UV_QDRAG
245 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
246# endif
247# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
248 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
249 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
250 real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng))
251 real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng))
252# endif
253# if defined ICESHELF
254 real(r8), intent(in) :: zice(LBi:UBi,LBj:UBj)
255# endif
256 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
257 real(r8), intent(in) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
258# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
259 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
260 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
261 real(r8), intent(in) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
262 real(r8), intent(in) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
263# endif
264# ifdef QCORRECTION
265 real(r8), intent(in) :: dqdt(LBi:UBi,LBj:UBj)
266 real(r8), intent(in) :: sst(LBi:UBi,LBj:UBj)
267# endif
268# if defined SCORRECTION || defined SRELAXATION
269 real(r8), intent(in) :: sss(LBi:UBi,LBj:UBj)
270# endif
271 real(r8), intent(in) :: stflux(LBi:UBi,LBj:UBj,NT(ng))
272 real(r8), intent(in) :: btflux(LBi:UBi,LBj:UBj,NT(ng))
273# if defined ICESHELF
274# ifdef SHORTWAVE
275 real(r8), intent(inout) :: srflx(LBi:UBi,LBj:UBj)
276# endif
277 real(r8), intent(inout) :: sustr(LBi:UBi,LBj:UBj)
278 real(r8), intent(inout) :: svstr(LBi:UBi,LBj:UBj)
279 real(r8), intent(inout) :: tl_sustr(LBi:UBi,LBj:UBj)
280 real(r8), intent(inout) :: tl_svstr(LBi:UBi,LBj:UBj)
281# endif
282# ifndef BBL_MODEL_NOT_YET
283 real(r8), intent(inout) :: bustr(LBi:UBi,LBj:UBj)
284 real(r8), intent(inout) :: bvstr(LBi:UBi,LBj:UBj)
285 real(r8), intent(inout) :: tl_bustr(LBi:UBi,LBj:UBj)
286 real(r8), intent(inout) :: tl_bvstr(LBi:UBi,LBj:UBj)
287# endif
288 real(r8), intent(inout) :: stflx(LBi:UBi,LBj:UBj,NT(ng))
289 real(r8), intent(inout) :: btflx(LBi:UBi,LBj:UBj,NT(ng))
290 real(r8), intent(inout) :: tl_stflx(LBi:UBi,LBj:UBj,NT(ng))
291 real(r8), intent(inout) :: tl_btflx(LBi:UBi,LBj:UBj,NT(ng))
292# endif
293!
294! Local variable declarations.
295!
296 integer :: i, j, itrc
297!
298 real(r8) :: EmP, tl_EmP
299# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
300 real(r8) :: cff1, cff2, cff3
301 real(r8) :: tl_cff1, tl_cff2, tl_cff3
302# endif
303
304# if (!defined BBL_MODEL_NOT_YET || defined ICESHELF) && defined UV_LOGDRAG
305 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wrk
306 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_wrk
307# endif
308
309# include "set_bounds.h"
310!
311!-----------------------------------------------------------------------
312! Tangent linear of loading surface and bottom net heat flux (degC m/s)
313! into state variables "stflx" and "btflx".
314!
315! Notice that the forcing net heat flux stflux(:,:,itemp) is processed
316! elsewhere from data, coupling, bulk flux parameterization,
317! or analytical formulas.
318!
319! During model coupling, we need to make sure that this forcing is
320! unaltered during the coupling interval when ROMS timestep size is
321! smaller. Notice that further manipulations to state variable
322! stflx(:,:,itemp) are allowed below.
323!-----------------------------------------------------------------------
324!
325 DO j=jstrr,jendr
326 DO i=istrr,iendr
327!^ stflx(i,j,itemp)=stflux(i,j,itemp)
328!^
329 tl_stflx(i,j,itemp)=0.0_r8 ! not needed in TLM
330!^ btflx(i,j,itemp)=btflux(i,j,itemp)
331!^
332 tl_btflx(i,j,itemp)=0.0_r8 ! not needed in TLM
333 END DO
334 END DO
335
336# ifdef QCORRECTION
337!
338!-----------------------------------------------------------------------
339! Add in flux correction to surface net heat flux (degC m/s).
340!-----------------------------------------------------------------------
341!
342! Add in net heat flux correction.
343!
344 DO j=jstrr,jendr
345 DO i=istrr,iendr
346!^ stflx(i,j,itemp)=stflx(i,j,itemp)+ &
347!^ & dqdt(i,j)*(t(i,j,N(ng),nrhs,itemp)-sst(i,j))
348!^
349# ifdef TL_IOMS
350 tl_stflx(i,j,itemp)=tl_stflx(i,j,itemp)+ &
351 & dqdt(i,j)*(tl_t(i,j,n(ng),nrhs,itemp)- &
352 & sst(i,j))
353# else
354 tl_stflx(i,j,itemp)=tl_stflx(i,j,itemp)+ &
355 & dqdt(i,j)*tl_t(i,j,n(ng),nrhs,itemp)
356# endif
357 END DO
358 END DO
359# endif
360
361# ifdef LIMIT_STFLX_COOLING
362!
363!-----------------------------------------------------------------------
364! If net heat flux is cooling and SST is at freezing point or below
365! then suppress further cooling. Note: stflx sign convention is that
366! positive means heating the ocean (J Wilkin).
367!-----------------------------------------------------------------------
368!
369! Below the surface heat flux stflx(:,:,itemp) is ZERO if cooling AND
370! the SST is cooler that the threshold. The value is retained if
371! warming.
372!
373! cff3 = 0 if SST warmer than threshold (cff1) - change nothing
374! cff3 = 1 if SST colder than threshold (cff1)
375!
376! 0.5*(cff2-ABS(cff2)) = 0 if flux is warming
377! = stflx(:,:,itemp) if flux is cooling
378!
379 cff1=-2.0_r8 ! nominal SST threshold to cease cooling
380 DO j=jstrr,jendr
381 DO i=istrr,iendr
382 cff2=stflx(i,j,itemp)
383 tl_cff2=tl_stflx(i,j,itemp)
384 cff3=0.5_r8*(1.0_r8+sign(1.0_r8,cff1-t(i,j,n(ng),nrhs,itemp)))
385!^ tl_cff3=0.5_r8*SIGN(1.0_r8, cff1-t(i,j,N(ng),nrhs,itemp))*0.0
386!^ tl_cff3=0.0_r8
387!^
388!^ stflx(i,j,itemp)=cff2-cff3*0.5_r8*(cff2-ABS(cff2))
389!^
390 tl_stflx(i,j,itemp)=(1.0_r8- &
391 & cff3*0.5_r8*(1.0_r8-sign(1.0_r8,cff2)))* &
392 & tl_cff2+ &
393# ifdef TL_IOMS
394 & cff3*0.5_r8*(cff2-abs(cff2))
395# endif
396 END DO
397 END DO
398# endif
399
400# ifdef SALINITY
401!
402!-----------------------------------------------------------------------
403! Multiply fresh water flux with surface salinity. If appropriate,
404! apply correction.
405!-----------------------------------------------------------------------
406!
407 DO j=jstrr,jendr
408 DO i=istrr,iendr
409 emp=stflux(i,j,isalt)
410 tl_emp=0.0_r8
411# if defined SCORRECTION
412!^ stflx(i,j,isalt)=Emp*t(i,j,N(ng),nrhs,isalt)- &
413!^ & Tnudg(isalt,ng)*Hz(i,j,N(ng))* &
414!^ & (t(i,j,N(ng),nrhs,isalt)-sss(i,j))
415!^
416# ifdef TL_IOMS
417 tl_stflx(i,j,isalt)=emp*tl_t(i,j,n(ng),nrhs,isalt)+ &
418 & tl_emp*t(i,j,n(ng),nrhs,isalt)- &
419 & tnudg(isalt,ng)* &
420 & (tl_hz(i,j,n(ng))* &
421 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
422 & hz(i,j,n(ng))* &
423 & (tl_t(i,j,n(ng),nrhs,isalt)+ &
424 & t(i,j,n(ng),nrhs,isalt)))- &
425 & emp*t(i,j,n(ng),nrhs,isalt)
426# else
427 tl_stflx(i,j,isalt)=emp*tl_t(i,j,n(ng),nrhs,isalt)+ &
428 & tl_emp*t(i,j,n(ng),nrhs,isalt)- &
429 & tnudg(isalt,ng)* &
430 & (tl_hz(i,j,n(ng))* &
431 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
432 & hz(i,j,n(ng))* &
433 & tl_t(i,j,n(ng),nrhs,isalt))
434# endif
435# elif defined SRELAXATION
436!^ stflx(i,j,isalt)=-Tnudg(isalt,ng)*Hz(i,j,N(ng))* &
437!^ & (t(i,j,N(ng),nrhs,isalt)-sss(i,j))
438!^
439# ifdef TL_IOMS
440 tl_stflx(i,j,isalt)=-tnudg(isalt,ng)* &
441 & (tl_hz(i,j,n(ng))* &
442 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
443 & hz(i,j,n(ng))* &
444 & (tl_t(i,j,n(ng),nrhs,isalt)- &
445 & t(i,j,n(ng),nrhs,isalt)))
446# else
447 tl_stflx(i,j,isalt)=-tnudg(isalt,ng)* &
448 & (tl_hz(i,j,n(ng))* &
449 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
450 & hz(i,j,n(ng))* &
451 & tl_t(i,j,n(ng),nrhs,isalt))
452# endif
453# else
454!^ stflx(i,j,isalt)=EmP*t(i,j,N(ng),nrhs,isalt)
455!^
456# ifdef TL_IOMS
457 tl_stflx(i,j,isalt)=emp*tl_t(i,j,n(ng),nrhs,isalt)+ &
458 & (tl_emp-emp)* &
459 & t(i,j,n(ng),nrhs,isalt)
460# else
461 tl_stflx(i,j,isalt)=emp*tl_t(i,j,n(ng),nrhs,isalt)+ &
462 & tl_emp*t(i,j,n(ng),nrhs,isalt)
463# endif
464# endif
465!^ btflx(i,j,isalt)=btflx(i,j,isalt)*t(i,j,1,nrhs,isalt)
466!^
467 tl_btflx(i,j,isalt)=btflx(i,j,isalt)* &
468 & tl_t(i,j,1,nrhs,isalt)+ &
469 & tl_btflx(i,j,isalt)* &
470 & t(i,j,1,nrhs,isalt)- &
471# ifdef TL_IOMS
472 & btflx(i,j,isalt)*t(i,j,1,nrhs,isalt)
473# endif
474 END DO
475 END DO
476# endif
477
478# if defined BIOLOGY || defined SEDIMENT || defined T_PASSIVE
479!
480!-----------------------------------------------------------------------
481! Load surface and bottom passive tracer fluxes (T m/s).
482!-----------------------------------------------------------------------
483!
484 DO itrc=nat+1,nt(ng)
485 DO j=jstrr,jendr
486 DO i=istrr,iendr
487!^ stflx(i,j,itrc)=stflux(i,j,itrc)
488!^
489 rp_stflx(i,j,itrc)=0.0_r8
490!^ btflx(i,j,itrc)=btflux(i,j,itrc)
491!^
492 rp_btflx(i,j,itrc)=0.0_r8
493 END DO
494 END DO
495 END DO
496# endif
497
498# ifdef ICESHELF
499!
500!-----------------------------------------------------------------------
501! If ice shelf cavities, zero out for now the surface tracer flux
502! over the ice.
503!-----------------------------------------------------------------------
504!
505 DO itrc=1,nt(ng)
506 DO j=jstrr,jendr
507 DO i=istrr,iendr
508 IF (zice(i,j).ne.0.0_r8) THEN
509!^ stflx(i,j,itrc)=0.0_r8
510!^
511 tl_stflx(i,j,itrc)=0.0_r8
512 END IF
513 END DO
514 END DO
515 END DO
516# ifdef SHORTWAVE
517 DO j=jstrr,jendr
518 DO i=istrr,iendr
519 IF (zice(i,j).ne.0.0_r8) THEN
520!^ srflx(i,j)=0.0_r8
521!^
522 srflx(i,j)=0.0_r8
523 END IF
524 END DO
525 END DO
526# endif
527!
528!-----------------------------------------------------------------------
529! If ice shelf cavities, replace surface wind stress with ice shelf
530! cavity stress (m2/s2).
531!-----------------------------------------------------------------------
532
533# if defined UV_LOGDRAG
534!
535! Set logarithmic ice shelf cavity stress.
536!
537 DO j=jstrv-1,jend
538 DO i=istru-1,iend
539 cff1=1.0_r8/log((z_w(i,j,n(ng))-z_r(i,j,n(ng)))/zobot(i,j))
540 tl_cff1=-cff1*cff1*(tl_z_w(i,j,n(ng))-tl_z_r(i,j,n(ng)))/ &
541 & (z_w(i,j,n(ng))-z_r(i,j,n(ng)))+ &
542# ifdef TL_IOMS
543 & cff1*(1.0_r8+cff1)
544# endif
545 cff2=vonkar*vonkar*cff1*cff1
546 tl_cff2=vonkar*vonkar*2.0_r8*cff1*tl_cff1- &
547# ifdef TL_IOMS
548 & cff2
549# endif
550 cff3=max(cdb_min,cff2)
551 tl_cff3=(0.5_r8-sign(0.5_r8,cdb_min-cff2))*tl_cff2+ &
552# ifdef TL_IOMS
553 & (0.5_r8+sign(0.5_r8,cdb_min-cff2))*cdb_min
554# endif
555 wrk(i,j)=min(cdb_max,cff3)
556 tl_wrk(i,j)=(0.5_r8-sign(0.5_r8,cff3-cdb_max))*tl_cff3+ &
557# ifdef TL_IOMS
558 & (0.5_r8+sign(0.5_r8,cff3-cdb_max))*cdb_max
559# endif
560 END DO
561 END DO
562 DO j=jstr,jend
563 DO i=istru,iend
564 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
565 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
566 & v(i ,j+1,n(ng),nrhs)+ &
567 & v(i-1,j ,n(ng),nrhs)+ &
568 & v(i-1,j+1,n(ng),nrhs))
569 tl_cff1=0.25_r8*(tl_v(i ,j ,n(ng),nrhs)+ &
570 & tl_v(i ,j+1,n(ng),nrhs)+ &
571 & tl_v(i-1,j ,n(ng),nrhs)+ &
572 & tl_v(i-1,j+1,n(ng),nrhs))
573 cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
574 IF (cff2.ne.0.0_r8) THEN
575 tl_cff2=(u(i,j,n(ng),nrhs)*tl_u(i,j,n(ng),nrhs)+ &
576 & cff1*tl_cff1)/cff2
577 ELSE
578 tl_cff2=0.0_r8
579 END IF
580 sustr(i,j)=-0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
581 & u(i,j,n(ng),nrhs)*cff2
582# ifdef TL_IOMS
583 tl_sustr(i,j)=-0.5_r8* &
584 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
585 & u(i,j,n(ng),nrhs)*cff2+ &
586 & (wrk(i-1,j)+wrk(i,j))* &
587 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
588 & u(i,j,n(ng),nrhs)*tl_cff2))+ &
589 & 2.0_r8*sustr(i,j)
590# else
591 tl_sustr(i,j)=-0.5_r8* &
592 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
593 & u(i,j,n(ng),nrhs)*cff2+ &
594 & (wrk(i-1,j)+wrk(i,j))* &
595 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
596 & u(i,j,n(ng),nrhs)*tl_cff2))
597# endif
598 END IF
599 END DO
600 END DO
601 DO j=jstrv,jend
602 DO i=istr,iend
603 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
604 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
605 & u(i+1,j ,n(ng),nrhs)+ &
606 & u(i ,j-1,n(ng),nrhs)+ &
607 & u(i+1,j-1,n(ng),nrhs))
608 tl_cff1=0.25_r8*(tl_u(i ,j ,n(ng),nrhs)+ &
609 & tl_u(i+1,j ,n(ng),nrhs)+ &
610 & tl_u(i ,j-1,n(ng),nrhs)+ &
611 & tl_u(i+1,j-1,n(ng),nrhs))
612 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
613 IF (cff2.ne.0.0_r8) THEN
614 tl_cff2=(cff1*tl_cff1+ &
615 & v(i,j,n(ng),nrhs)*tl_v(i,j,n(ng),nrhs))/cff2
616 ELSE
617 tl_cff2=0.0_r8
618 END IF
619 svstr(i,j)=-0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
620 & v(i,j,n(ng),nrhs)*cff2
621# ifdef TL_IOMS
622 tl_svstr(i,j)=-0.5_r8* &
623 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
624 & v(i,j,n(ng),nrhs)*cff2+ &
625 & (wrk(i,j-1)+wrk(i,j))* &
626 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
627 & v(i,j,n(ng),nrhs)*tl_cff2))+ &
628 & 2.0_r8*svstr(i,j)
629# else
630 tl_svstr(i,j)=-0.5_r8* &
631 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
632 & v(i,j,n(ng),nrhs)*cff2+ &
633 & (wrk(i,j-1)+wrk(i,j))* &
634 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
635 & v(i,j,n(ng),nrhs)*tl_cff2))
636# endif
637 END IF
638 END DO
639 END DO
640# elif defined UV_QDRAG
641!
642! Set quadratic ice shelf cavity stress.
643!
644 DO j=jstr,jend
645 DO i=istru,iend
646 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
647 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
648 & v(i ,j+1,n(ng),nrhs)+ &
649 & v(i-1,j ,n(ng),nrhs)+ &
650 & v(i-1,j+1,n(ng),nrhs))
651 tl_cff1=0.25_r8*(tl_v(i ,j ,n(ng),nrhs)+ &
652 & tl_v(i ,j+1,n(ng),nrhs)+ &
653 & tl_v(i-1,j ,n(ng),nrhs)+ &
654 & tl_v(i-1,j+1,n(ng),nrhs))
655 & cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
656 IF (cff2.ne.0.0_r8) THEN
657 tl_cff2=(u(i,j,n(ng),nrhs)*tl_u(i,j,n(ng),nrhs)+ &
658 & cff1*tl_cff1)/cff2
659 ELSE
660 tl_cff2=0.0_r8
661 END IF
662 sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
663 & u(i,j,n(ng),nrhs)*cff2
664# ifdef TL_IOMS
665 tl_sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
666 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
667 & u(i,j,n(ng),nrhs)*tl_cff2)+ &
668 & sustr(i,j)
669# else
670 tl_sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
671 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
672 & u(i,j,n(ng),nrhs)*tl_cff2)
673# endif
674 END IF
675 END DO
676 END DO
677 DO j=jstrv,jend
678 DO i=istr,iend
679 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
680 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
681 & u(i+1,j ,n(ng),nrhs)+ &
682 & u(i ,j-1,n(ng),nrhs)+ &
683 & u(i+1,j-1,n(ng),nrhs))
684 tl_cff1=0.25_r8*(tl_u(i ,j ,n(ng),nrhs)+ &
685 & tl_u(i+1,j ,n(ng),nrhs)+ &
686 & tl_u(i ,j-1,n(ng),nrhs)+ &
687 & tl_u(i+1,j-1,n(ng),nrhs))
688 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
689 IF (cff2.ne.0.0_r8) THEN
690 tl_cff2=(cff1*tl_cff1+ &
691 & v(i,j,n(ng),nrhs)*tl_v(i,j,n(ng),nrhs))/cff2
692 ELSE
693 tl_cff2=0.0_r8
694 END IF
695 svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
696 & v(i,j,n(ng),nrhs)*cff2
697# ifdef TL_IOMS
698 tl_svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
699 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
700 & v(i,j,n(ng),nrhs)*tl_cff2)+ &
701 & svstr(i,j)
702# else
703 tl_svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
704 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
705 & v(i,j,n(ng),nrhs)*tl_cff2)
706# endif
707 END IF
708 END DO
709 END DO
710# elif defined UV_LDRAG
711!
712! Set linear ice shelf cavity stress.
713!
714 DO j=jstr,jend
715 DO i=istru,iend
716 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
717 sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
718 & u(i,j,n(ng),nrhs)
719 tl_sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
720 & tl_u(i,j,n(ng),nrhs)
721 END IF
722 END DO
723 END DO
724 DO j=jstrv,jend
725 DO i=istr,iend
726 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
727 svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
728 & v(i,j,n(ng),nrhs)
729 tl_svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
730 & tl_v(i,j,n(ng),nrhs)
731 END IF
732 END DO
733 END DO
734# else
735 DO j=jstr,jend
736 DO i=istru,iend
737 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
738 sustr(i,j)=0.0_r8
739 tl_sustr(i,j)=0.0_r8
740 END IF
741 END DO
742 END DO
743 DO j=jstrv,jend
744 DO i=istr,iend
745 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
746 svstr(i,j)=0.0_r8
747 tl_svstr(i,j)=0.0_r8
748 END IF
749 END DO
750 END DO
751# endif
752!
753! Apply periodic or gradient boundary conditions for output
754! purposes only.
755!
756 CALL bc_u2d_tile (ng, tile, &
757 & lbi, ubi, lbj, ubj, &
758 & sustr)
759 CALL bc_u2d_tile (ng, tile, &
760 & lbi, ubi, lbj, ubj, &
761 & tl_sustr)
762 CALL bc_v2d_tile (ng, tile, &
763 & lbi, ubi, lbj, ubj, &
764 & svstr)
765 CALL bc_v2d_tile (ng, tile, &
766 & lbi, ubi, lbj, ubj, &
767 & tl_svstr)
768
769# ifdef DISTRIBUTE
770!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
771!^ & LBi, UBi, LBj, UBj, &
772!^ & NghostPoints, &
773!^ & EWperiodic(ng), NSperiodic(ng), &
774!^ & sustr, svstr)
775!^
776 CALL mp_exchange2d (ng, tile, irpm, 4, &
777 & lbi, ubi, lbj, ubj, &
778 & nghostpoints, &
779 & ewperiodic(ng), nsperiodic(ng), &
780 & sustr, svstr, &
781 & tl_sustr, tl_svstr)
782# endif
783# endif
784# ifndef BBL_MODEL_NOT_YET
785!
786!-----------------------------------------------------------------------
787! Set kinematic bottom momentum flux (m2/s2).
788!-----------------------------------------------------------------------
789
790# if defined UV_LOGDRAG
791!
792! Set logarithmic bottom stress.
793!
794 DO j=jstrv-1,jend
795 DO i=istru-1,iend
796 cff1=1.0_r8/log((z_r(i,j,1)-z_w(i,j,0))/zobot(i,j))
797 tl_cff1=-cff1*cff1*(tl_z_r(i,j,1)-tl_z_w(i,j,0))/ &
798 & (z_r(i,j,1)-z_w(i,j,0))+ &
799# ifdef TL_IOMS
800 & cff1*(1.0_r8+cff1)
801# endif
802 cff2=vonkar*vonkar*cff1*cff1
803 tl_cff2=vonkar*vonkar*2.0_r8*cff1*tl_cff1- &
804# ifdef TL_IOMS
805 & cff2
806# endif
807 cff3=max(cdb_min,cff2)
808 tl_cff3=(0.5_r8-sign(0.5_r8,cdb_min-cff2))*tl_cff2+ &
809# ifdef TL_IOMS
810 & (0.5_r8+sign(0.5_r8,cdb_min-cff2))*cdb_min
811# endif
812 wrk(i,j)=min(cdb_max,cff3)
813 tl_wrk(i,j)=(0.5_r8-sign(0.5_r8,cff3-cdb_max))*tl_cff3+ &
814# ifdef TL_IOMS
815 & (0.5_r8+sign(0.5_r8,cff3-cdb_max))*cdb_max
816# endif
817 END DO
818 END DO
819 DO j=jstr,jend
820 DO i=istru,iend
821 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
822 & v(i ,j+1,1,nrhs)+ &
823 & v(i-1,j ,1,nrhs)+ &
824 & v(i-1,j+1,1,nrhs))
825 tl_cff1=0.25_r8*(tl_v(i ,j ,1,nrhs)+ &
826 & tl_v(i ,j+1,1,nrhs)+ &
827 & tl_v(i-1,j ,1,nrhs)+ &
828 & tl_v(i-1,j+1,1,nrhs))
829 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
830 IF (cff2.ne.0.0_r8) THEN
831 tl_cff2=(u(i,j,1,nrhs)*tl_u(i,j,1,nrhs)+cff1*tl_cff1)/cff2
832 ELSE
833 tl_cff2=0.0_r8
834 END IF
835 bustr(i,j)=0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
836 & u(i,j,1,nrhs)*cff2
837# ifdef TL_IOMS
838 tl_bustr(i,j)=0.5_r8* &
839 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
840 & u(i,j,1,nrhs)*cff2+ &
841 & (wrk(i-1,j)+wrk(i,j))* &
842 & (tl_u(i,j,1,nrhs)*cff2+ &
843 & u(i,j,1,nrhs)*tl_cff2))- &
844 & 2.0_r8*bustr(i,j)
845# else
846 tl_bustr(i,j)=0.5_r8* &
847 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
848 & u(i,j,1,nrhs)*cff2+ &
849 & (wrk(i-1,j)+wrk(i,j))* &
850 & (tl_u(i,j,1,nrhs)*cff2+ &
851 & u(i,j,1,nrhs)*tl_cff2))
852# endif
853 END DO
854 END DO
855 DO j=jstrv,jend
856 DO i=istr,iend
857 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
858 & u(i+1,j ,1,nrhs)+ &
859 & u(i ,j-1,1,nrhs)+ &
860 & u(i+1,j-1,1,nrhs))
861 tl_cff1=0.25_r8*(tl_u(i ,j ,1,nrhs)+ &
862 & tl_u(i+1,j ,1,nrhs)+ &
863 & tl_u(i ,j-1,1,nrhs)+ &
864 & tl_u(i+1,j-1,1,nrhs))
865 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
866 IF (cff2.ne.0.0_r8) THEN
867 tl_cff2=(cff1*tl_cff1+v(i,j,1,nrhs)*tl_v(i,j,1,nrhs))/cff2
868 ELSE
869 tl_cff2=0.0_r8
870 END IF
871 bvstr(i,j)=0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
872 & v(i,j,1,nrhs)*cff2
873# ifdef TL_IOMS
874 tl_bvstr(i,j)=0.5_r8* &
875 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
876 & v(i,j,1,nrhs)*cff2+ &
877 & (wrk(i,j-1)+wrk(i,j))* &
878 & (tl_v(i,j,1,nrhs)*cff2+ &
879 & v(i,j,1,nrhs)*tl_cff2))- &
880 & 2.0_r8*bvstr(i,j)
881# else
882 tl_bvstr(i,j)=0.5_r8* &
883 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
884 & v(i,j,1,nrhs)*cff2+ &
885 & (wrk(i,j-1)+wrk(i,j))* &
886 & (tl_v(i,j,1,nrhs)*cff2+ &
887 & v(i,j,1,nrhs)*tl_cff2))
888# endif
889 END DO
890 END DO
891# elif defined UV_QDRAG
892!
893! Set quadratic bottom stress.
894!
895 DO j=jstr,jend
896 DO i=istru,iend
897 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
898 & v(i ,j+1,1,nrhs)+ &
899 & v(i-1,j ,1,nrhs)+ &
900 & v(i-1,j+1,1,nrhs))
901 tl_cff1=0.25_r8*(tl_v(i ,j ,1,nrhs)+ &
902 & tl_v(i ,j+1,1,nrhs)+ &
903 & tl_v(i-1,j ,1,nrhs)+ &
904 & tl_v(i-1,j+1,1,nrhs))
905 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
906 IF (cff2.ne.0.0_r8) THEN
907 tl_cff2=(u(i,j,1,nrhs)*tl_u(i,j,1,nrhs)+cff1*tl_cff1)/cff2
908 ELSE
909 tl_cff2=0.0_r8
910 END IF
911 bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
912 & u(i,j,1,nrhs)*cff2
913# ifdef TL_IOMS
914 tl_bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
915 & (tl_u(i,j,1,nrhs)*cff2+ &
916 & u(i,j,1,nrhs)*tl_cff2)- &
917 & bustr(i,j)
918# else
919 tl_bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
920 & (tl_u(i,j,1,nrhs)*cff2+ &
921 & u(i,j,1,nrhs)*tl_cff2)
922# endif
923 END DO
924 END DO
925 DO j=jstrv,jend
926 DO i=istr,iend
927 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
928 & u(i+1,j ,1,nrhs)+ &
929 & u(i ,j-1,1,nrhs)+ &
930 & u(i+1,j-1,1,nrhs))
931 tl_cff1=0.25_r8*(tl_u(i ,j ,1,nrhs)+ &
932 & tl_u(i+1,j ,1,nrhs)+ &
933 & tl_u(i ,j-1,1,nrhs)+ &
934 & tl_u(i+1,j-1,1,nrhs))
935 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
936 IF (cff2.ne.0.0_r8) THEN
937 tl_cff2=(cff1*tl_cff1+v(i,j,1,nrhs)*tl_v(i,j,1,nrhs))/cff2
938 ELSE
939 tl_cff2=0.0_r8
940 END IF
941 bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
942 & v(i,j,1,nrhs)*cff2
943# ifdef TL_IOMS
944 tl_bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
945 & (tl_v(i,j,1,nrhs)*cff2+ &
946 & v(i,j,1,nrhs)*tl_cff2)- &
947 & bvstr(i,j)
948# else
949 tl_bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
950 & (tl_v(i,j,1,nrhs)*cff2+ &
951 & v(i,j,1,nrhs)*tl_cff2)
952# endif
953 END DO
954 END DO
955# elif defined UV_LDRAG
956!
957! Set linear bottom stress.
958!
959 DO j=jstr,jend
960 DO i=istru,iend
961 bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
962 & u(i,j,1,nrhs)
963 tl_bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
964 & tl_u(i,j,1,nrhs)
965 END DO
966 END DO
967 DO j=jstrv,jend
968 DO i=istr,iend
969 bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
970 & v(i,j,1,nrhs)
971 tl_bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
972 & tl_v(i,j,1,nrhs)
973 END DO
974 END DO
975# endif
976!
977! Apply boundary conditions.
978!
979 CALL bc_u2d_tile (ng, tile, &
980 & lbi, ubi, lbj, ubj, &
981 & bustr)
982 CALL bc_u2d_tile (ng, tile, &
983 & lbi, ubi, lbj, ubj, &
984 & tl_bustr)
985 CALL bc_v2d_tile (ng, tile, &
986 & lbi, ubi, lbj, ubj, &
987 & bvstr)
988 CALL bc_v2d_tile (ng, tile, &
989 & lbi, ubi, lbj, ubj, &
990 & tl_bvstr)
991
992# ifdef DISTRIBUTE
993!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
994!^ & LBi, UBi, LBj, UBj, &
995!^ & NghostPoints, &
996!^ & EWperiodic(ng), NSperiodic(ng), &
997!^ & bustr, bvstr)
998!^
999 CALL mp_exchange2d (ng, tile, irpm, 4, &
1000 & lbi, ubi, lbj, ubj, &
1001 & nghostpoints, &
1002 & ewperiodic(ng), nsperiodic(ng), &
1003 & bustr, bvstr, &
1004 & tl_bustr, tl_bvstr)
1005# endif
1006# endif
1007!
1008 RETURN
1009 END SUBROUTINE rp_set_vbc_tile
1010
1011# else
1012
1013!
1014!***********************************************************************
1015 SUBROUTINE rp_set_vbc (ng, tile)
1016!***********************************************************************
1017!
1018 USE mod_param
1019 USE mod_forces
1020 USE mod_ocean
1021 USE mod_stepping
1022!
1023! Imported variable declarations.
1024!
1025 integer, intent(in) :: ng, tile
1026!
1027! Local variable declarations.
1028!
1029 character (len=*), parameter :: MyFile = &
1030 & __FILE__
1031!
1032# include "tile.h"
1033!
1034# ifdef PROFILE
1035 CALL wclock_on (ng, irpm, 6, __line__, myfile)
1036# endif
1037 CALL rp_set_vbc_tile (ng, tile, &
1038 & lbi, ubi, lbj, ubj, &
1039 & imins, imaxs, jmins, jmaxs, &
1040 & krhs(ng), kstp(ng), knew(ng), &
1041# if defined UV_LDRAG
1042 & grid(ng) % rdrag, &
1043# elif defined UV_QDRAG
1044 & grid(ng) % rdrag2, &
1045# endif
1046 & ocean(ng) % ubar, &
1047 & ocean(ng) % vbar, &
1048 & ocean(ng) % tl_ubar, &
1049 & ocean(ng) % tl_vbar, &
1050 & forces(ng) % bustr, &
1051 & forces(ng) % bvstr, &
1052 & forces(ng) % tl_bustr, &
1053 & forces(ng) % tl_bvstr)
1054# ifdef PROFILE
1055 CALL wclock_off (ng, irpm, 6, __line__, myfile)
1056# endif
1057!
1058 RETURN
1059 END SUBROUTINE rp_set_vbc
1060!
1061!***********************************************************************
1062 SUBROUTINE rp_set_vbc_tile (ng, tile, &
1063 & LBi, UBi, LBj, UBj, &
1064 & IminS, ImaxS, JminS, JmaxS, &
1065 & krhs, kstp, knew, &
1066# if defined UV_LDRAG
1067 & rdrag, &
1068# elif defined UV_QDRAG
1069 & rdrag2, &
1070# endif
1071 & ubar, vbar, &
1072 & tl_ubar, tl_vbar, &
1073 & bustr, bvstr, &
1074 & tl_bustr, tl_bvstr)
1075!***********************************************************************
1076!
1077 USE mod_param
1078 USE mod_scalars
1079!
1080 USE bc_2d_mod
1081# ifdef DISTRIBUTE
1082 USE mp_exchange_mod, ONLY : mp_exchange2d
1083# endif
1084!
1085! Imported variable declarations.
1086!
1087 integer, intent(in) :: ng, tile
1088 integer, intent(in) :: LBi, UBi, LBj, UBj
1089 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1090 integer, intent(in) :: krhs, kstp, knew
1091!
1092# ifdef ASSUMED_SHAPE
1093# if defined UV_LDRAG
1094 real(r8), intent(in) :: rdrag(LBi:,LBj:)
1095# elif defined UV_QDRAG
1096 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
1097# endif
1098 real(r8), intent(in) :: ubar(LBi:,LBj:,:)
1099 real(r8), intent(in) :: vbar(LBi:,LBj:,:)
1100 real(r8), intent(in) :: tl_ubar(LBi:,LBj:,:)
1101 real(r8), intent(in) :: tl_vbar(LBi:,LBj:,:)
1102 real(r8), intent(inout) :: bustr(LBi:,LBj:)
1103 real(r8), intent(inout) :: bvstr(LBi:,LBj:)
1104 real(r8), intent(inout) :: tl_bustr(LBi:,LBj:)
1105 real(r8), intent(inout) :: tl_bvstr(LBi:,LBj:)
1106# else
1107# if defined UV_LDRAG
1108 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
1109# elif defined UV_QDRAG
1110 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
1111# endif
1112 real(r8), intent(in) :: ubar(LBi:UBi,LBj:UBj,:)
1113 real(r8), intent(in) :: vbar(LBi:UBi,LBj:UBj,:)
1114 real(r8), intent(in) :: tl_ubar(LBi:UBi,LBj:UBj,:)
1115 real(r8), intent(in) :: tl_vbar(LBi:UBi,LBj:UBj,:)
1116 real(r8), intent(inout) :: bustr(LBi:UBi,LBj:UBj)
1117 real(r8), intent(inout) :: bvstr(LBi:UBi,LBj:UBj)
1118 real(r8), intent(inout) :: tl_bustr(LBi:UBi,LBj:UBj)
1119 real(r8), intent(inout) :: tl_bvstr(LBi:UBi,LBj:UBj)
1120# endif
1121!
1122! Local variable declarations.
1123!
1124 integer :: i, j
1125!
1126 real(r8) :: cff1, cff2
1127 real(r8) :: tl_cff1, tl_cff2
1128
1129# include "set_bounds.h"
1130!
1131!-----------------------------------------------------------------------
1132! Set kinematic barotropic bottom momentum stress (m2/s2).
1133!-----------------------------------------------------------------------
1134
1135# if defined UV_LDRAG
1136!
1137! Set linear bottom stress.
1138!
1139 DO j=jstr,jend
1140 DO i=istru,iend
1141 bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
1142 & ubar(i,j,krhs)
1143 tl_bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
1144 & tl_ubar(i,j,krhs)
1145 END DO
1146 END DO
1147 DO j=jstrv,jend
1148 DO i=istr,iend
1149 bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
1150 & vbar(i,j,krhs)
1151 tl_bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
1152 & tl_vbar(i,j,krhs)
1153 END DO
1154 END DO
1155# elif defined UV_QDRAG
1156!
1157! Set quadratic bottom stress.
1158!
1159 DO j=jstr,jend
1160 DO i=istru,iend
1161 cff1=0.25_r8*(vbar(i ,j ,krhs)+ &
1162 & vbar(i ,j+1,krhs)+ &
1163 & vbar(i-1,j ,krhs)+ &
1164 & vbar(i-1,j+1,krhs))
1165 tl_cff1=0.25_r8*(tl_vbar(i ,j ,krhs)+ &
1166 & tl_vbar(i ,j+1,krhs)+ &
1167 & tl_vbar(i-1,j ,krhs)+ &
1168 & tl_vbar(i-1,j+1,krhs))
1169 cff2=sqrt(ubar(i,j,krhs)*ubar(i,j,krhs)+cff1*cff1)
1170 IF (cff2.ne.0.0_r8) THEN
1171 tl_cff2=(ubar(i,j,krhs)*tl_ubar(i,j,krhs)+cff1*tl_cff1)/cff2
1172 ELSE
1173 tl_cff2=0.0_r8
1174 END IF
1175 bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
1176 & ubar(i,j,krhs)*cff2
1177# ifdef TL_IOMS
1178 tl_bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
1179 & (tl_ubar(i,j,krhs)*cff2+ &
1180 & ubar(i,j,krhs)*tl_cff2)- &
1181 & bustr(i,j)
1182# else
1183 tl_bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
1184 & (tl_ubar(i,j,krhs)*cff2+ &
1185 & ubar(i,j,krhs)*tl_cff2)
1186# endif
1187 END DO
1188 END DO
1189 DO j=jstrv,jend
1190 DO i=istr,iend
1191 cff1=0.25_r8*(ubar(i ,j ,krhs)+ &
1192 & ubar(i+1,j ,krhs)+ &
1193 & ubar(i ,j-1,krhs)+ &
1194 & ubar(i+1,j-1,krhs))
1195 tl_cff1=0.25_r8*(tl_ubar(i ,j ,krhs)+ &
1196 & tl_ubar(i+1,j ,krhs)+ &
1197 & tl_ubar(i ,j-1,krhs)+ &
1198 & tl_ubar(i+1,j-1,krhs))
1199 cff2=sqrt(cff1*cff1+vbar(i,j,krhs)*vbar(i,j,krhs))
1200 IF (cff2.ne.0.0_r8) THEN
1201 tl_cff2=(cff1*tl_cff1+vbar(i,j,krhs)*tl_vbar(i,j,krhs))/cff2
1202 ELSE
1203 tl_cff2=0.0_r8
1204 END IF
1205 bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
1206 & vbar(i,j,krhs)*cff2
1207# ifdef TL_IOMS
1208 tl_bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
1209 & (tl_vbar(i,j,krhs)*cff2+ &
1210 & vbar(i,j,krhs)*tl_cff2)- &
1211 & bvstr(i,j)
1212# else
1213 tl_bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
1214 & (tl_vbar(i,j,krhs)*cff2+ &
1215 & vbar(i,j,krhs)*tl_cff2)
1216# endif
1217 END DO
1218 END DO
1219# endif
1220!
1221! Apply boundary conditions.
1222!
1223 CALL bc_u2d_tile (ng, tile, &
1224 & lbi, ubi, lbj, ubj, &
1225 & bustr)
1226 CALL bc_u2d_tile (ng, tile, &
1227 & lbi, ubi, lbj, ubj, &
1228 & tl_bustr)
1229 CALL bc_v2d_tile (ng, tile, &
1230 & lbi, ubi, lbj, ubj, &
1231 & bvstr)
1232 CALL bc_v2d_tile (ng, tile, &
1233 & lbi, ubi, lbj, ubj, &
1234 & tl_bvstr)
1235
1236# ifdef DISTRIBUTE
1237!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
1238!^ & LBi, UBi, LBj, UBj, &
1239!^ & NghostPoints, &
1240!^ & EWperiodic(ng), NSperiodic(ng), &
1241!^ & bustr, bvstr)
1242!^
1243 CALL mp_exchange2d (ng, tile, irpm, 4, &
1244 & lbi, ubi, lbj, ubj, &
1245 & nghostpoints, &
1246 & ewperiodic(ng), nsperiodic(ng), &
1247 & bustr, bvstr, &
1248 & tl_bustr, tl_bvstr)
1249# endif
1250!
1251 RETURN
1252 END SUBROUTINE rp_set_vbc_tile
1253# endif
1254#endif
1255 END MODULE rp_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::irpm
integer, parameter irpm
Definition mod_param.F:664
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::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
rp_set_vbc_mod
Definition rp_set_vbc.F:2
rp_set_vbc_mod::rp_set_vbc_tile
subroutine rp_set_vbc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nrhs, hz, tl_hz, zobot, z_r, z_w, tl_z_r, tl_z_w, zice, t, tl_t, u, v, tl_u, tl_v, dqdt, sst, sss, sustr, svstr, tl_sustr, tl_svstr, stflux, btflux, stflx, btflx, tl_stflx, tl_btflx)
Definition rp_set_vbc.F:165
rp_set_vbc_mod::rp_set_vbc
subroutine, public rp_set_vbc(ng, tile)
Definition rp_set_vbc.F:33
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