ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
tl_set_vbc_mod Module Reference

Functions/Subroutines

subroutine, public tl_set_vbc (ng, tile)
 
subroutine tl_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, tl_sustr, tl_svstr, stflux, btflux, stflx, btflx, tl_stflx, tl_btflx)
 

Function/Subroutine Documentation

◆ tl_set_vbc()

subroutine, public tl_set_vbc_mod::tl_set_vbc ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 32 of file tl_set_vbc.F.

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, itlm, 6, __line__, myfile)
54# endif
55 CALL tl_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) % tl_sustr, &
97 & forces(ng) % tl_svstr, &
98# endif
99# ifndef BBL_MODEL_NOT_YET
100 & forces(ng) % tl_bustr, &
101 & forces(ng) % tl_bvstr, &
102# endif
103 & forces(ng) % stflux, &
104 & forces(ng) % btflux, &
105 & forces(ng) % stflx, &
106 & forces(ng) % btflx, &
107 & forces(ng) % tl_stflx, &
108 & forces(ng) % tl_btflx)
109# ifdef PROFILE
110 CALL wclock_off (ng, itlm, 6, __line__, myfile)
111# endif
112!
113 RETURN
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::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_stepping
Definition mod_stepping.F:2
mod_stepping::nrhs
integer, dimension(:), allocatable nrhs
Definition mod_stepping.F:70
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

References mod_forces::forces, mod_grid::grid, mod_param::itlm, mod_stepping::nrhs, mod_ocean::ocean, tl_set_vbc_tile(), wclock_off(), and wclock_on().

Referenced by tl_main3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ tl_set_vbc_tile()

subroutine tl_set_vbc_mod::tl_set_vbc_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) nrhs,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
real(r8), dimension(lbi:,lbj:,:), intent(in) tl_hz,
real(r8), dimension(lbi:,lbj:), intent(in) zobot,
real(r8), dimension(lbi:,lbj:,:), intent(in) z_r,
real(r8), dimension(lbi:,lbj:,0:), intent(in) z_w,
real(r8), dimension(lbi:,lbj:,:), intent(in) tl_z_r,
real(r8), dimension(lbi:,lbj:,0:), intent(in) tl_z_w,
real(r8), dimension(lbi:,lbj:), intent(in) zice,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(in) t,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(in) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) u,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) v,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) tl_v,
real(r8), dimension(lbi:,lbj:), intent(in) dqdt,
real(r8), dimension(lbi:,lbj:), intent(in) sst,
real(r8), dimension(lbi:,lbj:), intent(in) sss,
real(r8), dimension(lbi:,lbj:), intent(inout) tl_sustr,
real(r8), dimension(lbi:,lbj:), intent(inout) tl_svstr,
real(r8), dimension(lbi:,lbj:,:), intent(in) stflux,
real(r8), dimension(lbi:,lbj:,:), intent(in) btflux,
real(r8), dimension(lbi:,lbj:,:), intent(in) stflx,
real(r8), dimension(lbi:,lbj:,:), intent(in) btflx,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_stflx,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_btflx )
private

Definition at line 117 of file tl_set_vbc.F.

159!***********************************************************************
160!
161 USE mod_param
162 USE mod_scalars
163!
164 USE bc_2d_mod
165# ifdef DISTRIBUTE
166 USE mp_exchange_mod, ONLY : mp_exchange2d
167# endif
168!
169! Imported variable declarations.
170!
171 integer, intent(in) :: ng, tile
172 integer, intent(in) :: LBi, UBi, LBj, UBj
173 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
174 integer, intent(in) :: nrhs
175!
176# ifdef ASSUMED_SHAPE
177 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
178 real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
179# if defined UV_LOGDRAG
180 real(r8), intent(in) :: ZoBot(LBi:,LBj:)
181# elif defined UV_LDRAG
182 real(r8), intent(in) :: rdrag(LBi:,LBj:)
183# elif defined UV_QDRAG
184 real(r8), intent(in) :: rdrag2(LBi:,LBj:)
185# endif
186# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
187 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
188 real(r8), intent(in) :: z_w(LBi:,LBj:,0:)
189 real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
190 real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
191# endif
192# if defined ICESHELF
193 real(r8), intent(in) :: zice(LBi:,LBj:)
194# endif
195 real(r8), intent(in) :: t(LBi:,LBj:,:,:,:)
196 real(r8), intent(in) :: tl_t(LBi:,LBj:,:,:,:)
197# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
198 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
199 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
200 real(r8), intent(in) :: tl_u(LBi:,LBj:,:,:)
201 real(r8), intent(in) :: tl_v(LBi:,LBj:,:,:)
202# endif
203 real(r8), intent(in) :: stflx(LBi:,LBj:,:)
204 real(r8), intent(in) :: btflx(LBi:,LBj:,:)
205# ifdef QCORRECTION
206 real(r8), intent(in) :: dqdt(LBi:,LBj:)
207 real(r8), intent(in) :: sst(LBi:,LBj:)
208# endif
209# if defined SCORRECTION || defined SRELAXATION
210 real(r8), intent(in) :: sss(LBi:,LBj:)
211# endif
212 real(r8), intent(in) :: stflux(LBi:,LBj:,:)
213 real(r8), intent(in) :: btflux(LBi:,LBj:,:)
214# if defined ICESHELF
215# ifdef SHORTWAVE
216 real(r8), intent(inout) :: srflx(LBi:,LBj:)
217# endif
218 real(r8), intent(inout) :: tl_sustr(LBi:,LBj:)
219 real(r8), intent(inout) :: tl_svstr(LBi:,LBj:)
220# endif
221# ifndef BBL_MODEL_NOT_YET
222 real(r8), intent(inout) :: tl_bustr(LBi:,LBj:)
223 real(r8), intent(inout) :: tl_bvstr(LBi:,LBj:)
224# endif
225 real(r8), intent(inout) :: tl_stflx(LBi:,LBj:,:)
226 real(r8), intent(inout) :: tl_btflx(LBi:,LBj:,:)
227# else
228 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
229 real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng))
230# if defined UV_LOGDRAG
231 real(r8), intent(in) :: ZoBot(LBi:UBi,LBj:UBj)
232# elif defined UV_LDRAG
233 real(r8), intent(in) :: rdrag(LBi:UBi,LBj:UBj)
234# elif defined UV_QDRAG
235 real(r8), intent(in) :: rdrag2(LBi:UBi,LBj:UBj)
236# endif
237# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
238 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
239 real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng))
240 real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng))
241 real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng))
242# endif
243# if defined ICESHELF
244 real(r8), intent(in) :: zice(LBi:UBi,LBj:UBj)
245# endif
246 real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
247 real(r8), intent(in) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
248# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
249 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
250 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
251 real(r8), intent(in) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
252 real(r8), intent(in) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
253# endif
254 real(r8), intent(in) :: stflx(LBi:UBi,LBj:UBj,NT(ng))
255 real(r8), intent(in) :: btflx(LBi:UBi,LBj:UBj,NT(ng))
256# ifdef QCORRECTION
257 real(r8), intent(in) :: dqdt(LBi:UBi,LBj:UBj)
258 real(r8), intent(in) :: sst(LBi:UBi,LBj:UBj)
259# endif
260# if defined SCORRECTION || defined SRELAXATION
261 real(r8), intent(in) :: sss(LBi:UBi,LBj:UBj)
262# endif
263 real(r8), intent(in) :: stflux(LBi:UBi,LBj:UBj,NT(ng))
264 real(r8), intent(in) :: btflux(LBi:UBi,LBj:UBj,NT(ng))
265# if defined ICESHELF
266# ifdef SHORTWAVE
267 real(r8), intent(inout) :: srflx(LBi:UBi,LBj:UBj)
268# endif
269 real(r8), intent(inout) :: tl_sustr(LBi:UBi,LBj:UBj)
270 real(r8), intent(inout) :: tl_svstr(LBi:UBi,LBj:UBj)
271# endif
272# ifndef BBL_MODEL_NOT_YET
273 real(r8), intent(inout) :: tl_bustr(LBi:UBi,LBj:UBj)
274 real(r8), intent(inout) :: tl_bvstr(LBi:UBi,LBj:UBj)
275# endif
276 real(r8), intent(inout) :: tl_stflx(LBi:UBi,LBj:UBj,NT(ng))
277 real(r8), intent(inout) :: tl_btflx(LBi:UBi,LBj:UBj,NT(ng))
278# endif
279!
280! Local variable declarations.
281!
282 integer :: i, j, itrc
283!
284 real(r8) :: EmP, tl_EmP
285# if !defined BBL_MODEL_NOT_YET || defined ICESHELF
286 real(r8) :: cff1, cff2, cff3
287 real(r8) :: tl_cff1, tl_cff2, tl_cff3
288# endif
289
290# if (!defined BBL_MODEL_NOT_YET || defined ICESHELF) && defined UV_LOGDRAG
291 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wrk
292 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_wrk
293# endif
294
295# include "set_bounds.h"
296!
297!-----------------------------------------------------------------------
298! Tangent linear of loading surface and bottom net heat flux (degC m/s)
299! into state variables "stflx" and "btflx".
300!
301! Notice that the forcing net heat flux stflux(:,:,itemp) is processed
302! elsewhere from data, coupling, bulk flux parameterization,
303! or analytical formulas.
304!
305! During model coupling, we need to make sure that this forcing is
306! unaltered during the coupling interval when ROMS timestep size is
307! smaller. Notice that further manipulations to state variable
308! stflx(:,:,itemp) are allowed below.
309!-----------------------------------------------------------------------
310!
311 DO j=jstrr,jendr
312 DO i=istrr,iendr
313!^ stflx(i,j,itemp)=stflux(i,j,itemp)
314!^
315 tl_stflx(i,j,itemp)=0.0_r8 ! not needed in TLM
316!^ btflx(i,j,itemp)=btflux(i,j,itemp)
317!^
318 tl_btflx(i,j,itemp)=0.0_r8 ! not needed in TLM
319 END DO
320 END DO
321
322# ifdef QCORRECTION
323!
324!-----------------------------------------------------------------------
325! Add in flux correction to surface net heat flux (degC m/s).
326!-----------------------------------------------------------------------
327!
328! Add in net heat flux correction.
329!
330 DO j=jstrr,jendr
331 DO i=istrr,iendr
332!^ stflx(i,j,itemp)=stflx(i,j,itemp)+ &
333!^ & dqdt(i,j)*(t(i,j,N(ng),nrhs,itemp)-sst(i,j))
334!^
335 tl_stflx(i,j,itemp)=tl_stflx(i,j,itemp)+ &
336 & dqdt(i,j)*tl_t(i,j,n(ng),nrhs,itemp)
337 END DO
338 END DO
339# endif
340
341# ifdef LIMIT_STFLX_COOLING
342!
343!-----------------------------------------------------------------------
344! If net heat flux is cooling and SST is at freezing point or below
345! then suppress further cooling. Note: stflx sign convention is that
346! positive means heating the ocean (J Wilkin).
347!-----------------------------------------------------------------------
348!
349! Below the surface heat flux stflx(:,:,itemp) is ZERO if cooling AND
350! the SST is cooler that the threshold. The value is retained if
351! warming.
352!
353! cff3 = 0 if SST warmer than threshold (cff1) - change nothing
354! cff3 = 1 if SST colder than threshold (cff1)
355!
356! 0.5*(cff2-ABS(cff2)) = 0 if flux is warming
357! = stflx(:,:,itemp) if flux is cooling
358!
359 cff1=-2.0_r8 ! nominal SST threshold to cease cooling
360 DO j=jstrr,jendr
361 DO i=istrr,iendr
362 cff2=stflx(i,j,itemp)
363 tl_cff2=tl_stflx(i,j,itemp)
364 cff3=0.5_r8*(1.0_r8+sign(1.0_r8,cff1-t(i,j,n(ng),nrhs,itemp)))
365!^ tl_cff3=0.5_r8*SIGN(1.0_r8, cff1-t(i,j,N(ng),nrhs,itemp))*0.0
366!^ tl_cff3=0.0_r8
367!^
368!^ stflx(i,j,itemp)=cff2-cff3*0.5_r8*(cff2-ABS(cff2))
369!^
370 tl_stflx(i,j,itemp)=(1.0_r8- &
371 & cff3*0.5_r8*(1.0_r8-sign(1.0_r8,cff2)))* &
372 & tl_cff2
373 END DO
374 END DO
375# endif
376
377# ifdef SALINITY
378!
379!-----------------------------------------------------------------------
380! Tangent linear of multiply freshwater fluxes with surface and bottom
381! salinity.
382!
383! If appropriate, apply correction. Notice that input stflux(:,:,isalt)
384! is the net freshwater flux (E-P; m/s) from data, coupling, bulk flux
385! parameterization, or analytical formula. It has not been multiplied
386! by the surface and bottom salinity.
387!-----------------------------------------------------------------------
388!
389 DO j=jstrr,jendr
390 DO i=istrr,iendr
391 emp=stflux(i,j,isalt)
392 tl_emp=0.0_r8
393# if defined SCORRECTION
394!^ stflx(i,j,isalt)=EmP*t(i,j,N(ng),nrhs,isalt)- &
395!^ & Tnudg(isalt,ng)*Hz(i,j,N(ng))* &
396!^ & (t(i,j,N(ng),nrhs,isalt)-sss(i,j))
397!^
398 tl_stflx(i,j,isalt)=emp*tl_t(i,j,n(ng),nrhs,isalt)+ &
399 & tl_emp*t(i,j,n(ng),nrhs,isalt)- &
400 & tnudg(isalt,ng)* &
401 & (tl_hz(i,j,n(ng))* &
402 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
403 & hz(i,j,n(ng))* &
404 & tl_t(i,j,n(ng),nrhs,isalt))
405# elif defined SRELAXATION
406!^ stflx(i,j,isalt)=-Tnudg(isalt,ng)*Hz(i,j,N(ng))* &
407!^ & (t(i,j,N(ng),nrhs,isalt)-sss(i,j))
408!^
409 tl_stflx(i,j,isalt)=-tnudg(isalt,ng)* &
410 & (tl_hz(i,j,n(ng))* &
411 & (t(i,j,n(ng),nrhs,isalt)-sss(i,j))+ &
412 & hz(i,j,n(ng))* &
413 & tl_t(i,j,n(ng),nrhs,isalt))
414# else
415!^ stflx(i,j,isalt)=EmP*t(i,j,N(ng),nrhs,isalt)
416!^
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# endif
420!^ btflx(i,j,isalt)=btflx(i,j,isalt)*t(i,j,1,nrhs,isalt)
421!^
422 tl_btflx(i,j,isalt)=btflx(i,j,isalt)* &
423 & tl_t(i,j,1,nrhs,isalt)
424 END DO
425 END DO
426# endif
427
428# if defined BIOLOGY || defined SEDIMENT || defined T_PASSIVE
429!
430!-----------------------------------------------------------------------
431! Load surface and bottom passive tracer fluxes (T m/s).
432!-----------------------------------------------------------------------
433!
434 DO itrc=nat+1,nt(ng)
435 DO j=jstrr,jendr
436 DO i=istrr,iendr
437!^ stflx(i,j,itrc)=stflux(i,j,itrc)
438!^
439 tl_stflx(i,j,itrc)=0.0_r8
440!^ btflx(i,j,itrc)=btflux(i,j,itrc)
441!^
442 tl_btflx(i,j,itrc)=0.0_r8
443 END DO
444 END DO
445 END DO
446# endif
447
448# ifdef ICESHELF
449!
450!-----------------------------------------------------------------------
451! If ice shelf cavities, zero out for now the surface tracer flux
452! over the ice.
453!-----------------------------------------------------------------------
454!
455 DO itrc=1,nt(ng)
456 DO j=jstrr,jendr
457 DO i=istrr,iendr
458 IF (zice(i,j).ne.0.0_r8) THEN
459!^ stflx(i,j,itrc)=0.0_r8
460!^
461 tl_stflx(i,j,itrc)=0.0_r8
462 END IF
463 END DO
464 END DO
465 END DO
466# ifdef SHORTWAVE
467 DO j=jstrr,jendr
468 DO i=istrr,iendr
469 IF (zice(i,j).ne.0.0_r8) THEN
470!^ srflx(i,j)=0.0_r8
471!^
472 srflx(i,j)=0.0_r8
473 END IF
474 END DO
475 END DO
476# endif
477!
478!-----------------------------------------------------------------------
479! If ice shelf cavities, replace surface wind stress with ice shelf
480! cavity stress (m2/s2).
481!-----------------------------------------------------------------------
482
483# if defined UV_LOGDRAG
484!
485! Set logarithmic ice shelf cavity stress.
486!
487 DO j=jstrv-1,jend
488 DO i=istru-1,iend
489 cff1=1.0_r8/log((z_w(i,j,n(ng))-z_r(i,j,n(ng)))/zobot(i,j))
490 tl_cff1=-cff1*cff1*(tl_z_w(i,j,n(ng))-tl_z_r(i,j,n(ng)))/ &
491 & (z_w(i,j,n(ng))-z_r(i,j,n(ng)))
492 cff2=vonkar*vonkar*cff1*cff1
493 tl_cff2=vonkar*vonkar*2.0_r8*cff1*tl_cff1
494 cff3=max(cdb_min,cff2)
495 tl_cff3=(0.5_r8-sign(0.5_r8,cdb_min-cff2))*tl_cff2
496 wrk(i,j)=min(cdb_max,cff3)
497 tl_wrk(i,j)=(0.5_r8-sign(0.5_r8,cff3-cdb_max))*tl_cff3
498 END DO
499 END DO
500 DO j=jstr,jend
501 DO i=istru,iend
502 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
503 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
504 & v(i ,j+1,n(ng),nrhs)+ &
505 & v(i-1,j ,n(ng),nrhs)+ &
506 & v(i-1,j+1,n(ng),nrhs))
507 tl_cff1=0.25_r8*(tl_v(i ,j ,n(ng),nrhs)+ &
508 & tl_v(i ,j+1,n(ng),nrhs)+ &
509 & tl_v(i-1,j ,n(ng),nrhs)+ &
510 & tl_v(i-1,j+1,n(ng),nrhs))
511 cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
512 IF (cff2.ne.0.0_r8) THEN
513 tl_cff2=(u(i,j,n(ng),nrhs)*tl_u(i,j,n(ng),nrhs)+ &
514 & cff1*tl_cff1)/cff2
515 ELSE
516 tl_cff2=0.0_r8
517 END IF
518!^ sustr(i,j)=-0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
519!^ & u(i,j,N(ng),nrhs)*cff2
520!^
521 tl_sustr(i,j)=-0.5_r8* &
522 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
523 & u(i,j,n(ng),nrhs)*cff2+ &
524 & (wrk(i-1,j)+wrk(i,j))* &
525 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
526 & u(i,j,n(ng),nrhs)*tl_cff2))
527 END IF
528 END DO
529 END DO
530 DO j=jstrv,jend
531 DO i=istr,iend
532 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
533 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
534 & u(i+1,j ,n(ng),nrhs)+ &
535 & u(i ,j-1,n(ng),nrhs)+ &
536 & u(i+1,j-1,n(ng),nrhs))
537 tl_cff1=0.25_r8*(tl_u(i ,j ,n(ng),nrhs)+ &
538 & tl_u(i+1,j ,n(ng),nrhs)+ &
539 & tl_u(i ,j-1,n(ng),nrhs)+ &
540 & tl_u(i+1,j-1,n(ng),nrhs))
541 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
542 IF (cff2.ne.0.0_r8) THEN
543 tl_cff2=(cff1*tl_cff1+ &
544 & v(i,j,n(ng),nrhs)*tl_v(i,j,n(ng),nrhs))/cff2
545 ELSE
546 tl_cff2=0.0_r8
547 END IF
548!^ svstr(i,j)=-0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
549!^ & v(i,j,N(ng),nrhs)*cff2
550!^
551 tl_svstr(i,j)=-0.5_r8* &
552 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
553 & v(i,j,n(ng),nrhs)*cff2+ &
554 & (wrk(i,j-1)+wrk(i,j))* &
555 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
556 & v(i,j,n(ng),nrhs)*tl_cff2))
557 END IF
558 END DO
559 END DO
560# elif defined UV_QDRAG
561!
562! Set quadratic ice shelf cavity stress.
563!
564 DO j=jstr,jend
565 DO i=istru,iend
566 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
567 cff1=0.25_r8*(v(i ,j ,n(ng),nrhs)+ &
568 & v(i ,j+1,n(ng),nrhs)+ &
569 & v(i-1,j ,n(ng),nrhs)+ &
570 & v(i-1,j+1,n(ng),nrhs))
571 tl_cff1=0.25_r8*(tl_v(i ,j ,n(ng),nrhs)+ &
572 & tl_v(i ,j+1,n(ng),nrhs)+ &
573 & tl_v(i-1,j ,n(ng),nrhs)+ &
574 & tl_v(i-1,j+1,n(ng),nrhs))
575 & cff2=sqrt(u(i,j,n(ng),nrhs)*u(i,j,n(ng),nrhs)+cff1*cff1)
576 IF (cff2.ne.0.0_r8) THEN
577 tl_cff2=(u(i,j,n(ng),nrhs)*tl_u(i,j,n(ng),nrhs)+ &
578 & cff1*tl_cff1)/cff2
579 ELSE
580 tl_cff2=0.0_r8
581 END IF
582!^ sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
583!^ & u(i,j,N(ng),nrhs)*cff2
584!^
585 tl_sustr(i,j)=-0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
586 & (tl_u(i,j,n(ng),nrhs)*cff2+ &
587 & u(i,j,n(ng),nrhs)*tl_cff2)
588 END IF
589 END DO
590 END DO
591 DO j=jstrv,jend
592 DO i=istr,iend
593 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
594 cff1=0.25_r8*(u(i ,j ,n(ng),nrhs)+ &
595 & u(i+1,j ,n(ng),nrhs)+ &
596 & u(i ,j-1,n(ng),nrhs)+ &
597 & u(i+1,j-1,n(ng),nrhs))
598 tl_cff1=0.25_r8*(tl_u(i ,j ,n(ng),nrhs)+ &
599 & tl_u(i+1,j ,n(ng),nrhs)+ &
600 & tl_u(i ,j-1,n(ng),nrhs)+ &
601 & tl_u(i+1,j-1,n(ng),nrhs))
602 cff2=sqrt(cff1*cff1+v(i,j,n(ng),nrhs)*v(i,j,n(ng),nrhs))
603 IF (cff2.ne.0.0_r8) THEN
604 tl_cff2=(cff1*tl_cff1+ &
605 & v(i,j,n(ng),nrhs)*tl_v(i,j,n(ng),nrhs))/cff2
606 ELSE
607 tl_cff2=0.0_r8
608 END IF
609!^ svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
610!^ & v(i,j,N(ng),nrhs)*cff2
611!^
612 tl_svstr(i,j)=-0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
613 & (tl_v(i,j,n(ng),nrhs)*cff2+ &
614 & v(i,j,n(ng),nrhs)*tl_cff2)
615 END IF
616 END DO
617 END DO
618# elif defined UV_LDRAG
619!
620! Set linear ice shelf cavity stress.
621!
622 DO j=jstr,jend
623 DO i=istru,iend
624 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
625!^ sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
626!^ & u(i,j,N(ng),nrhs)
627!^
628 tl_sustr(i,j)=-0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
629 & tl_u(i,j,n(ng),nrhs)
630 END IF
631 END DO
632 END DO
633 DO j=jstrv,jend
634 DO i=istr,iend
635 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
636!^ svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
637!^ & v(i,j,N(ng),nrhs)
638!^
639 tl_svstr(i,j)=-0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
640 & tl_v(i,j,n(ng),nrhs)
641 END IF
642 END DO
643 END DO
644# else
645 DO j=jstr,jend
646 DO i=istru,iend
647 IF (zice(i,j)*zice(i-1,j).ne.0.0_r8) THEN
648!^ sustr(i,j)=0.0_r8
649!^
650 tl_sustr(i,j)=0.0_r8
651 END IF
652 END DO
653 END DO
654 DO j=jstrv,jend
655 DO i=istr,iend
656 IF (zice(i,j)*zice(i,j-1).ne.0.0_r8) THEN
657!^ svstr(i,j)=0.0_r8
658!^
659 tl_svstr(i,j)=0.0_r8
660 END IF
661 END DO
662 END DO
663# endif
664!
665! Apply periodic or gradient boundary conditions for output
666! purposes only.
667!
668!^ CALL bc_u2d_tile (ng, tile, &
669!^ & LBi, UBi, LBj, UBj, &
670!^ & sustr)
671!^
672 CALL bc_u2d_tile (ng, tile, &
673 & lbi, ubi, lbj, ubj, &
674 & tl_sustr)
675!^ CALL bc_v2d_tile (ng, tile, &
676!^ & LBi, UBi, LBj, UBj, &
677!^ & svstr)
678!^
679 CALL bc_v2d_tile (ng, tile, &
680 & lbi, ubi, lbj, ubj, &
681 & tl_svstr)
682
683# ifdef DISTRIBUTE
684!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
685!^ & LBi, UBi, LBj, UBj, &
686!^ & NghostPoints, &
687!^ & EWperiodic(ng), NSperiodic(ng), &
688!^ & sustr, svstr)
689!^
690 CALL mp_exchange2d (ng, tile, itlm, 2, &
691 & lbi, ubi, lbj, ubj, &
692 & nghostpoints, &
693 & ewperiodic(ng), nsperiodic(ng), &
694 & tl_sustr, tl_svstr)
695# endif
696# endif
697# ifndef BBL_MODEL_NOT_YET
698!
699!-----------------------------------------------------------------------
700! Set kinematic bottom momentum flux (m2/s2).
701!-----------------------------------------------------------------------
702
703# if defined UV_LOGDRAG
704!
705! Set logarithmic bottom stress.
706!
707 DO j=jstrv-1,jend
708 DO i=istru-1,iend
709 cff1=1.0_r8/log((z_r(i,j,1)-z_w(i,j,0))/zobot(i,j))
710 tl_cff1=-cff1*cff1*(tl_z_r(i,j,1)-tl_z_w(i,j,0))/ &
711 & (z_r(i,j,1)-z_w(i,j,0))
712 cff2=vonkar*vonkar*cff1*cff1
713 tl_cff2=vonkar*vonkar*2.0_r8*cff1*tl_cff1
714 cff3=max(cdb_min,cff2)
715 tl_cff3=(0.5_r8-sign(0.5_r8,cdb_min-cff2))*tl_cff2
716 wrk(i,j)=min(cdb_max,cff3)
717 tl_wrk(i,j)=(0.5_r8-sign(0.5_r8,cff3-cdb_max))*tl_cff3
718 END DO
719 END DO
720 DO j=jstr,jend
721 DO i=istru,iend
722 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
723 & v(i ,j+1,1,nrhs)+ &
724 & v(i-1,j ,1,nrhs)+ &
725 & v(i-1,j+1,1,nrhs))
726 tl_cff1=0.25_r8*(tl_v(i ,j ,1,nrhs)+ &
727 & tl_v(i ,j+1,1,nrhs)+ &
728 & tl_v(i-1,j ,1,nrhs)+ &
729 & tl_v(i-1,j+1,1,nrhs))
730 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
731 IF (cff2.ne.0.0_r8) THEN
732 tl_cff2=(u(i,j,1,nrhs)*tl_u(i,j,1,nrhs)+cff1*tl_cff1)/cff2
733 ELSE
734 tl_cff2=0.0_r8
735 END IF
736!^ bustr(i,j)=0.5_r8*(wrk(i-1,j)+wrk(i,j))* &
737!^ & u(i,j,1,nrhs)*cff2
738!^
739 tl_bustr(i,j)=0.5_r8* &
740 & ((tl_wrk(i-1,j)+tl_wrk(i,j))* &
741 & u(i,j,1,nrhs)*cff2+ &
742 & (wrk(i-1,j)+wrk(i,j))* &
743 & (tl_u(i,j,1,nrhs)*cff2+ &
744 & u(i,j,1,nrhs)*tl_cff2))
745 END DO
746 END DO
747 DO j=jstrv,jend
748 DO i=istr,iend
749 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
750 & u(i+1,j ,1,nrhs)+ &
751 & u(i ,j-1,1,nrhs)+ &
752 & u(i+1,j-1,1,nrhs))
753 tl_cff1=0.25_r8*(tl_u(i ,j ,1,nrhs)+ &
754 & tl_u(i+1,j ,1,nrhs)+ &
755 & tl_u(i ,j-1,1,nrhs)+ &
756 & tl_u(i+1,j-1,1,nrhs))
757 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
758 IF (cff2.ne.0.0_r8) THEN
759 tl_cff2=(cff1*tl_cff1+v(i,j,1,nrhs)*tl_v(i,j,1,nrhs))/cff2
760 ELSE
761 tl_cff2=0.0_r8
762 END IF
763!^ bvstr(i,j)=0.5_r8*(wrk(i,j-1)+wrk(i,j))* &
764!^ & v(i,j,1,nrhs)*cff2
765!^
766 tl_bvstr(i,j)=0.5_r8* &
767 & ((tl_wrk(i,j-1)+tl_wrk(i,j))* &
768 & v(i,j,1,nrhs)*cff2+ &
769 & (wrk(i,j-1)+wrk(i,j))* &
770 & (tl_v(i,j,1,nrhs)*cff2+ &
771 & v(i,j,1,nrhs)*tl_cff2))
772 END DO
773 END DO
774# elif defined UV_QDRAG
775!
776! Set quadratic bottom stress.
777!
778 DO j=jstr,jend
779 DO i=istru,iend
780 cff1=0.25_r8*(v(i ,j ,1,nrhs)+ &
781 & v(i ,j+1,1,nrhs)+ &
782 & v(i-1,j ,1,nrhs)+ &
783 & v(i-1,j+1,1,nrhs))
784 tl_cff1=0.25_r8*(tl_v(i ,j ,1,nrhs)+ &
785 & tl_v(i ,j+1,1,nrhs)+ &
786 & tl_v(i-1,j ,1,nrhs)+ &
787 & tl_v(i-1,j+1,1,nrhs))
788 cff2=sqrt(u(i,j,1,nrhs)*u(i,j,1,nrhs)+cff1*cff1)
789 IF (cff2.ne.0.0_r8) THEN
790 tl_cff2=(u(i,j,1,nrhs)*tl_u(i,j,1,nrhs)+cff1*tl_cff1)/cff2
791 ELSE
792 tl_cff2=0.0_r8
793 END IF
794!^ bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
795!^ & u(i,j,1,nrhs)*cff2
796!^
797 tl_bustr(i,j)=0.5_r8*(rdrag2(i-1,j)+rdrag2(i,j))* &
798 & (tl_u(i,j,1,nrhs)*cff2+ &
799 & u(i,j,1,nrhs)*tl_cff2)
800 END DO
801 END DO
802 DO j=jstrv,jend
803 DO i=istr,iend
804 cff1=0.25_r8*(u(i ,j ,1,nrhs)+ &
805 & u(i+1,j ,1,nrhs)+ &
806 & u(i ,j-1,1,nrhs)+ &
807 & u(i+1,j-1,1,nrhs))
808 tl_cff1=0.25_r8*(tl_u(i ,j ,1,nrhs)+ &
809 & tl_u(i+1,j ,1,nrhs)+ &
810 & tl_u(i ,j-1,1,nrhs)+ &
811 & tl_u(i+1,j-1,1,nrhs))
812 cff2=sqrt(cff1*cff1+v(i,j,1,nrhs)*v(i,j,1,nrhs))
813 IF (cff2.ne.0.0_r8) THEN
814 tl_cff2=(cff1*tl_cff1+v(i,j,1,nrhs)*tl_v(i,j,1,nrhs))/cff2
815 ELSE
816 tl_cff2=0.0_r8
817 END IF
818!^ bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
819!^ & v(i,j,1,nrhs)*cff2
820!^
821 tl_bvstr(i,j)=0.5_r8*(rdrag2(i,j-1)+rdrag2(i,j))* &
822 & (tl_v(i,j,1,nrhs)*cff2+ &
823 & v(i,j,1,nrhs)*tl_cff2)
824 END DO
825 END DO
826# elif defined UV_LDRAG
827!
828! Set linear bottom stress.
829!
830 DO j=jstr,jend
831 DO i=istru,iend
832!^ bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
833!^ & u(i,j,1,nrhs)
834!^
835 tl_bustr(i,j)=0.5_r8*(rdrag(i-1,j)+rdrag(i,j))* &
836 & tl_u(i,j,1,nrhs)
837 END DO
838 END DO
839 DO j=jstrv,jend
840 DO i=istr,iend
841!^ bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
842!^ & v(i,j,1,nrhs)
843!^
844 tl_bvstr(i,j)=0.5_r8*(rdrag(i,j-1)+rdrag(i,j))* &
845 & tl_v(i,j,1,nrhs)
846 END DO
847 END DO
848# endif
849!
850! Apply boundary conditions.
851!
852!^ CALL bc_u2d_tile (ng, tile, &
853!^ & LBi, UBi, LBj, UBj, &
854!^ & bustr)
855!^
856 CALL bc_u2d_tile (ng, tile, &
857 & lbi, ubi, lbj, ubj, &
858 & tl_bustr)
859!^ CALL bc_v2d_tile (ng, tile, &
860!^ & LBi, UBi, LBj, UBj, &
861!^ & bvstr)
862!^
863 CALL bc_v2d_tile (ng, tile, &
864 & lbi, ubi, lbj, ubj, &
865 & tl_bvstr)
866
867# ifdef DISTRIBUTE
868!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
869!^ & LBi, UBi, LBj, UBj, &
870!^ & NghostPoints, &
871!^ & EWperiodic(ng), NSperiodic(ng), &
872!^ & bustr, bvstr)
873!^
874 CALL mp_exchange2d (ng, tile, itlm, 2, &
875 & lbi, ubi, lbj, ubj, &
876 & nghostpoints, &
877 & ewperiodic(ng), nsperiodic(ng), &
878 & tl_bustr, tl_bvstr)
879# endif
880# endif
881!
882 RETURN
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_param::nat
integer nat
Definition mod_param.F:499
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
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
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

References bc_2d_mod::bc_u2d_tile(), bc_2d_mod::bc_v2d_tile(), mod_scalars::cdb_max, mod_scalars::cdb_min, mod_scalars::ewperiodic, mod_forces::forces, mod_grid::grid, mod_scalars::isalt, mod_scalars::itemp, mod_param::itlm, mod_stepping::knew, mod_stepping::krhs, mod_stepping::kstp, mp_exchange_mod::mp_exchange2d(), mod_param::nat, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_ocean::ocean, tl_set_vbc_tile(), mod_scalars::tnudg, mod_scalars::vonkar, wclock_off(), and wclock_on().

Referenced by tl_set_vbc(), and tl_set_vbc_tile().

Here is the call graph for this function:
Here is the caller graph for this function: