ROMS
Loading...
Searching...
No Matches
ad_obc_volcons.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE ad_obc_volcons_mod
3#ifdef ADJOINT
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 routines computes adjoint integral mass flux "obc_flux" !
13! across the open boundaries, which is needed to enforce global !
14! mass conservation constraint. !
15! !
16!=======================================================================
17!
18 implicit none
19
20 PRIVATE
21 PUBLIC :: ad_obc_flux_tile, ad_set_duv_bc_tile
22
23 CONTAINS
24!
25!***********************************************************************
26 SUBROUTINE ad_obc_flux (ng, tile, kinp)
27!***********************************************************************
28!
29 USE mod_param
30 USE mod_grid
31 USE mod_ocean
32 USE mod_stepping
33!
34! Imported variable declarations.
35!
36 integer, intent(in) :: ng, tile, kinp
37!
38! Local variable declarations.
39!
40# include "tile.h"
41!
42 CALL ad_obc_flux_tile (ng, tile, &
43 & lbi, ubi, lbj, ubj, &
44 & imins, imaxs, jmins, jmaxs, &
45 & kinp, &
46# ifdef MASKING
47 & grid(ng) % umask, &
48 & grid(ng) % vmask, &
49# endif
50 & grid(ng) % h, &
51 & grid(ng) % ad_h, &
52 & grid(ng) % om_v, &
53 & grid(ng) % on_u, &
54 & ocean(ng) % ubar, &
55 & ocean(ng) % vbar, &
56 & ocean(ng) % zeta, &
57 & ocean(ng) % ad_ubar, &
58 & ocean(ng) % ad_vbar, &
59 & ocean(ng) % ad_zeta)
60 RETURN
61 END SUBROUTINE ad_obc_flux
62!
63!***********************************************************************
64 SUBROUTINE ad_obc_flux_tile (ng, tile, &
65 & LBi, UBi, LBj, UBj, &
66 & IminS, ImaxS, JminS, JmaxS, &
67 & kinp, &
68# ifdef MASKING
69 & umask, vmask, &
70# endif
71 & h, ad_h, &
72 & om_v, on_u, &
73 & ubar, vbar, zeta, &
74 & ad_ubar, ad_vbar, ad_zeta)
75!***********************************************************************
76!
77 USE mod_param
78 USE mod_parallel
79 USE mod_scalars
80!
81! Imported variable declarations.
82!
83 integer, intent(in) :: ng, tile
84 integer, intent(in) :: lbi, ubi, lbj, ubj
85 integer, intent(in) :: imins, imaxs, jmins, jmaxs
86 integer, intent(in) :: kinp
87!
88# ifdef ASSUMED_SHAPE
89# ifdef MASKING
90 real(r8), intent(in) :: umask(lbi:,lbj:)
91 real(r8), intent(in) :: vmask(lbi:,lbj:)
92# endif
93 real(r8), intent(in) :: h(lbi:,lbj:)
94 real(r8), intent(in) :: om_v(lbi:,lbj:)
95 real(r8), intent(in) :: on_u(lbi:,lbj:)
96
97 real(r8), intent(in) :: ubar(lbi:,lbj:,:)
98 real(r8), intent(in) :: vbar(lbi:,lbj:,:)
99 real(r8), intent(in) :: zeta(lbi:,lbj:,:)
100
101 real(r8), intent(inout) :: ad_h(lbi:,lbj:)
102 real(r8), intent(inout) :: ad_ubar(lbi:,lbj:,:)
103 real(r8), intent(inout) :: ad_vbar(lbi:,lbj:,:)
104 real(r8), intent(inout) :: ad_zeta(lbi:,lbj:,:)
105# else
106# ifdef MASKING
107 real(r8), intent(in) :: umask(lbi:ubi,lbj:ubj)
108 real(r8), intent(in) :: vmask(lbi:ubi,lbj:ubj)
109# endif
110 real(r8), intent(in) :: h(lbi:ubi,lbj:ubj)
111 real(r8), intent(in) :: om_v(lbi:ubi,lbj:ubj)
112 real(r8), intent(in) :: on_u(lbi:ubi,lbj:ubj)
113
114 real(r8), intent(in) :: ubar(lbi:ubi,lbj:ubj,:)
115 real(r8), intent(in) :: vbar(lbi:ubi,lbj:ubj,:)
116 real(r8), intent(in) :: zeta(lbi:ubi,lbj:ubj,:)
117
118 real(r8), intent(inout) :: ad_h(lbi:ubi,lbj:ubj)
119 real(r8), intent(inout) :: ad_ubar(lbi:ubi,lbj:ubj,:)
120 real(r8), intent(inout) :: ad_vbar(lbi:ubi,lbj:ubj,:)
121 real(r8), intent(inout) :: ad_zeta(lbi:ubi,lbj:ubj,:)
122# endif
123!
124! Local variable declarations.
125!
126 integer :: i, j
127
128 real(r8) :: cff, my_area, my_flux
129 real(r8) :: adfac, ad_cff, ad_my_area, ad_my_flux
130
131# ifdef DISTRIBUTE
132 real(r8), dimension(2) :: rbuffer
133 character (len=3), dimension(2) :: op_handle
134# endif
135!
136# include "set_bounds.h"
137!
138!-----------------------------------------------------------------------
139! Initialize adjoint private variables.
140!-----------------------------------------------------------------------
141!
142 ad_cff=0.0_r8
143!
144!-----------------------------------------------------------------------
145! Perform adjoint global summation and compute correction velocity.
146!-----------------------------------------------------------------------
147!
148 IF (any(ad_volcons(:,ng))) THEN
149!^ tl_ubar_xs=tl_bc_flux/bc_area- &
150!^ & tl_bc_area*ubar_xs/bc_area
151!^
152 ad_bc_area=-ad_ubar_xs*ubar_xs/bc_area
153 ad_bc_flux=ad_ubar_xs/bc_area
154 ad_ubar_xs=0.0_r8
155!^ tl_bc_flux=tl_bc_flux+tl_my_flux
156!^
157 ad_my_flux=ad_bc_flux
158!^ tl_bc_area=tl_bc_area+tl_my_area
159!^
160 ad_my_area=ad_bc_area
161 END IF
162!
163!-----------------------------------------------------------------------
164! Compute open segments cross-section area and mass flux.
165!-----------------------------------------------------------------------
166!
167 IF (ad_volcons(inorth,ng)) THEN
168 IF (domain(ng)%Northern_Edge(tile)) THEN
169 DO i=istr,iend
170 cff=0.5_r8*om_v(i,jend+1)* &
171 & (zeta(i,jend ,kinp)+h(i,jend )+ &
172 & zeta(i,jend+1,kinp)+h(i,jend+1))
173# ifdef MASKING
174 cff=cff*vmask(i,jend+1)
175# endif
176!^ tl_my_flux=tl_my_flux- &
177!^ & tl_cff*vbar(i,Jend+1,kinp)- &
178!^ & cff*tl_vbar(i,Jend+1,kinp)
179!^
180 ad_vbar(i,jend+1,kinp)=ad_vbar(i,jend+1,kinp)- &
181 & cff*ad_my_flux
182 ad_cff=ad_cff-ad_my_flux*vbar(i,jend+1,kinp)
183!^ tl_my_area=tl_my_area+tl_cff
184!^
185 ad_cff=ad_cff+ad_my_area
186# ifdef MASKING
187!^ tl_cff=tl_cff*vmask(i,Jend+1)
188!^
189 ad_cff=ad_cff*vmask(i,jend+1)
190# endif
191!^ tl_cff=0.5_r8*om_v(i,Jend+1)* &
192!^ & (tl_zeta(i,Jend ,kinp)+tl_h(i,Jend )+ &
193!^ & tl_zeta(i,Jend+1,kinp)+tl_h(i,Jend+1))
194!^
195 adfac=0.5_r8*om_v(i,jend+1)*ad_cff
196 ad_zeta(i,jend ,kinp)=ad_zeta(i,jend ,kinp)+adfac
197 ad_zeta(i,jend+1,kinp)=ad_zeta(i,jend+1,kinp)+adfac
198 ad_h(i,jend )=ad_h(i,jend )+adfac
199 ad_h(i,jend+1)=ad_h(i,jend+1)+adfac
200 ad_cff=0.0_r8
201 END DO
202 END IF
203 END IF
204
205 IF (ad_volcons(isouth,ng)) THEN
206 IF (domain(ng)%Southern_Edge(tile)) THEN
207 DO i=istr,iend
208 cff=0.5_r8*om_v(i,jstr)* &
209 & (zeta(i,jstr-1,kinp)+h(i,jstr-1)+ &
210 & zeta(i,jstr ,kinp)+h(i,jstr ))
211# ifdef MASKING
212 cff=cff*vmask(i,jstr)
213# endif
214!^ tl_my_flux=tl_my_flux+ &
215!^ & tl_cff*vbar(i,JstrV-1,kinp)+ &
216!^ & cff*tl_vbar(i,JstrV-1,kinp)
217!^
218 ad_vbar(i,jstrv-1,kinp)=ad_vbar(i,jstrv-1,kinp)+ &
219 & cff*ad_my_flux
220 ad_cff=ad_cff+ad_my_flux*vbar(i,jstrv-1,kinp)
221!^ tl_my_area=tl_my_area+tl_cff
222!^
223 ad_cff=ad_cff+ad_my_area
224# ifdef MASKING
225!^ tl_cff=tl_cff*vmask(i,Jstr)
226!^
227 ad_cff=ad_cff*vmask(i,jstr)
228# endif
229!^ tl_cff=0.5_r8*om_v(i,Jstr)* &
230!^ & (tl_zeta(i,Jstr-1,kinp)+tl_h(i,Jstr-1)+ &
231!^ & tl_zeta(i,Jstr ,kinp)+tl_h(i,Jstr ))
232!^
233 adfac=0.5_r8*om_v(i,jstr)*ad_cff
234 ad_zeta(i,jstr-1,kinp)=ad_zeta(i,jstr-1,kinp)+adfac
235 ad_zeta(i,jstr ,kinp)=ad_zeta(i,jstr ,kinp)+adfac
236 ad_h(i,jstr-1)=ad_h(i,jstr-1)+adfac
237 ad_h(i,jstr )=ad_h(i,jstr )+adfac
238 ad_cff=0.0_r8
239 END DO
240 END IF
241 END IF
242
243 IF (ad_volcons(ieast,ng)) THEN
244 IF (domain(ng)%Eastern_Edge(tile)) THEN
245 DO j=jstr,jend
246 cff=0.5_r8*on_u(iend+1,j)* &
247 & (zeta(iend ,j,kinp)+h(iend ,j)+ &
248 & zeta(iend+1,j,kinp)+h(iend+1,j))
249# ifdef MASKING
250 cff=cff*umask(iend+1,j)
251# endif
252!^ tl_my_flux=tl_my_flux- &
253!^ & tl_cff*ubar(Iend+1,j,kinp)- &
254!^ & cff*tl_ubar(Iend+1,j,kinp)
255!^
256 ad_ubar(iend+1,j,kinp)=ad_ubar(iend+1,j,kinp)- &
257 & cff*ad_my_flux
258 ad_cff=ad_cff-ad_my_flux*ubar(iend+1,j,kinp)
259!^ tl_my_area=tl_my_area+tl_cff
260!^
261 ad_cff=ad_cff+ad_my_area
262# ifdef MASKING
263!^ tl_cff=tl_cff*umask(Iend+1,j)
264!^
265 ad_cff=ad_cff*umask(iend+1,j)
266# endif
267!^ tl_cff=0.5_r8*on_u(Iend+1,j)* &
268!^ & (tl_zeta(Iend ,j,kinp)+tl_h(Iend ,j)+ &
269!^ & tl_zeta(Iend+1,j,kinp)+tl_h(Iend+1,j))
270!^
271 adfac=0.5_r8*on_u(iend+1,j)*ad_cff
272 ad_zeta(iend ,j,kinp)=ad_zeta(iend ,j,kinp)+adfac
273 ad_zeta(iend+1,j,kinp)=ad_zeta(iend+1,j,kinp)+adfac
274 ad_h(iend ,j)=ad_h(iend ,j)+adfac
275 ad_h(iend+1,j)=ad_h(iend+1,j)+adfac
276 ad_cff=0.0_r8
277 END DO
278 END IF
279 END IF
280
281 IF (ad_volcons(iwest,ng)) THEN
282 IF (domain(ng)%Western_Edge(tile)) THEN
283 DO j=jstr,jend
284 cff=0.5_r8*on_u(istr,j)* &
285 & (zeta(istr-1,j,kinp)+h(istr-1,j)+ &
286 & zeta(istr ,j,kinp)+h(istr ,j))
287# ifdef MASKING
288 cff=cff*umask(istr,j)
289# endif
290!^ tl_my_flux=tl_my_flux+ &
291!^ & tl_cff*ubar(Istr,j,kinp)+ &
292!^ & cff*tl_ubar(Istr,j,kinp)
293!^
294 ad_ubar(istr,j,kinp)=ad_ubar(istr,j,kinp)+ &
295 & cff*ad_my_flux
296 ad_cff=ad_cff+ad_my_flux*ubar(istr,j,kinp)
297!^ tl_my_area=tl_my_area+tl_cff
298!^
299 ad_cff=ad_cff+ad_my_area
300# ifdef MASKING
301!^ tl_cff=tl_cff*umask(Istr,j)
302!^
303 ad_cff=ad_cff*umask(istr,j)
304# endif
305!^ tl_cff=0.5_r8*on_u(Istr,j)* &
306!^ & (tl_zeta(Istr-1,j,kinp)+tl_h(Istr-1,j)+ &
307!^ & tl_zeta(Istr ,j,kinp)+tl_h(Istr ,j))
308!^
309 adfac=0.5_r8*on_u(istr,j)*ad_cff
310 ad_zeta(istr-1,j,kinp)=ad_zeta(istr-1,j,kinp)+adfac
311 ad_zeta(istr ,j,kinp)=ad_zeta(istr ,j,kinp)+adfac
312 ad_h(istr-1,j)=ad_h(istr-1,j)+adfac
313 ad_h(istr-1,j)=ad_h(istr-1,j)+adfac
314 ad_cff=0.0_r8
315 END DO
316 END IF
317 END IF
318
319!^ tl_my_area=0.0_r8
320!^ tl_my_flux=0.0_r8
321!^
322 ad_my_area=0.0_r8
323 ad_my_flux=0.0_r8
324
325 RETURN
326 END SUBROUTINE ad_obc_flux_tile
327!
328!***********************************************************************
329 SUBROUTINE ad_set_duv_bc_tile (ng, tile, &
330 & LBi, UBi, LBj, UBj, &
331 & IminS, ImaxS, JminS, JmaxS, &
332 & kinp, &
333# ifdef MASKING
334 & umask, vmask, &
335# endif
336 & om_v, on_u, &
337 & ubar, vbar, &
338 & ad_ubar, ad_vbar, &
339 & Drhs, Duon, Dvom, &
340 & ad_Drhs, ad_Duon, ad_Dvom)
341!***********************************************************************
342!
343 USE mod_param
344 USE mod_scalars
345 USE mod_parallel
346
347# ifdef DISTRIBUTE
348!
349 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
350 USE distribute_mod, ONLY : mp_reduce
351# endif
352!
353! Imported variable declarations.
354!
355 integer, intent(in) :: ng, tile
356 integer, intent(in) :: lbi, ubi, lbj, ubj
357 integer, intent(in) :: imins, imaxs, jmins, jmaxs
358 integer, intent(in) :: kinp
359!
360# ifdef ASSUMED_SHAPE
361# ifdef MASKING
362 real(r8), intent(in) :: umask(lbi:,lbj:)
363 real(r8), intent(in) :: vmask(lbi:,lbj:)
364# endif
365 real(r8), intent(in) :: om_v(lbi:,lbj:)
366 real(r8), intent(in) :: on_u(lbi:,lbj:)
367
368 real(r8), intent(in) :: ubar(lbi:,lbj:,:)
369 real(r8), intent(in) :: vbar(lbi:,lbj:,:)
370 real(r8), intent(in) :: drhs(imins:,jmins:)
371 real(r8), intent(in) :: duon(imins:,jmins:)
372 real(r8), intent(in) :: dvom(imins:,jmins:)
373
374 real(r8), intent(inout) :: ad_ubar(lbi:,lbj:,:)
375 real(r8), intent(inout) :: ad_vbar(lbi:,lbj:,:)
376 real(r8), intent(inout) :: ad_drhs(imins:,jmins:)
377 real(r8), intent(inout) :: ad_duon(imins:,jmins:)
378 real(r8), intent(inout) :: ad_dvom(imins:,jmins:)
379# else
380# ifdef MASKING
381 real(r8), intent(in) :: umask(lbi:ubi,lbj:ubj)
382 real(r8), intent(in) :: vmask(lbi:ubi,lbj:ubj)
383# endif
384 real(r8), intent(in) :: om_v(lbi:ubi,lbj:ubj)
385 real(r8), intent(in) :: on_u(lbi:ubi,lbj:ubj)
386
387 real(r8), intent(in) :: ubar(lbi:ubi,lbj:ubj,:)
388 real(r8), intent(in) :: vbar(lbi:ubi,lbj:ubj,:)
389 real(r8), intent(in) :: drhs(imins:imaxs,jmins:jmaxs)
390 real(r8), intent(in) :: duon(imins:imaxs,jmins:jmaxs)
391 real(r8), intent(in) :: dvom(imins:imaxs,jmins:jmaxs)
392
393 real(r8), intent(inout) :: ad_ubar(lbi:ubi,lbj:ubj,:)
394 real(r8), intent(inout) :: ad_vbar(lbi:ubi,lbj:ubj,:)
395 real(r8), intent(inout) :: ad_drhs(imins:imaxs,jmins:jmaxs)
396 real(r8), intent(inout) :: ad_duon(imins:imaxs,jmins:jmaxs)
397 real(r8), intent(inout) :: ad_dvom(imins:imaxs,jmins:jmaxs)
398# endif
399!
400! Local variable declarations.
401!
402 integer :: nsub, i, j
403
404 real(r8) :: adfac, adfac1, adfac2, adfac3
405 real(r8) :: ad_my_ubar_xs
406# ifdef DISTRIBUTE
407 real(r8) :: rbuffer
408 character (len=3) :: op_handle
409# endif
410
411# include "set_bounds.h"
412
413# ifdef DISTRIBUTE
414# define I_RANGE IstrU,MIN(Iend+1,Lm(ng))
415# define J_RANGE JstrV,MIN(Jend+1,Mm(ng))
416# else
417# define I_RANGE MAX(2,IstrU-1),MIN(Iend+1,Lm(ng))
418# define J_RANGE MAX(2,JstrV-1),MIN(Jend+1,Mm(ng))
419# endif
420!
421!-----------------------------------------------------------------------
422! Set vertically integrated mass fluxes "Duon" and "Dvom" along
423! the open boundaries in such a way that the integral volume is
424! conserved. This is done by applying "ubar_xs" correction to
425! the velocities.
426!-----------------------------------------------------------------------
427!
428 ad_my_ubar_xs=0.0_r8
429!
430# ifdef DISTRIBUTE
431
432! Do a special exchange to avoid having three ghost points for high
433! order numerical stencil.
434!
435 IF (ad_volcons(isouth,ng).or.ad_volcons(inorth,ng)) THEN
436!^ CALL mp_exchange2d (ng, tile, iTLM, 1, &
437!^ & IminS, ImaxS, JminS, JmaxS, &
438!^ & NghostPoints, &
439!^ & EWperiodic(ng), NSperiodic(ng), &
440!^ & tl_Dvom)
441!^
442 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
443 & imins, imaxs, jmins, jmaxs, &
444 & nghostpoints, &
445 & ewperiodic(ng), nsperiodic(ng), &
446 & ad_dvom)
447 END IF
448
449 IF (ad_volcons(iwest,ng).or.ad_volcons(ieast,ng)) THEN
450!^ CALL mp_exchange2d (ng, tile, iTLM, 1, &
451!^ & IminS, ImaxS, JminS, JmaxS, &
452!^ & NghostPoints, &
453!^ & EWperiodic(ng), NSperiodic(ng), &
454!^ & tl_Duon)
455!^
456 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
457 & imins, imaxs, jmins, jmaxs, &
458 & nghostpoints, &
459 & ewperiodic(ng), nsperiodic(ng), &
460 & ad_duon)
461 END IF
462# endif
463
464 IF (ad_volcons(inorth,ng)) THEN
465 IF (domain(ng)%Northern_Edge(tile)) THEN
466 DO i=-2+i_range+1
467# ifdef MASKING
468!^ tl_Dvom(i,Jend+1)=tl_Dvom(i,Jend+1)*vmask(i,Jend+1)
469!^
470 ad_dvom(i,jend+1)=ad_dvom(i,jend+1)*vmask(i,jend+1)
471# endif
472!^ tl_Dvom(i,Jend+1)=0.5_r8* &
473!^ & ((tl_Drhs(i,Jend+1)+tl_Drhs(i,Jend))* &
474!^ & (vbar(i,Jend+1,kinp)+ubar_xs)+ &
475!^ & (Drhs(i,Jend+1)+Drhs(i,Jend))* &
476!^ & (tl_vbar(i,Jend+1,kinp)+tl_ubar_xs))* &
477!^ & om_v(i,Jend+1)
478!^
479 adfac=0.5_r8*om_v(i,jend+1)*ad_dvom(i,jend+1)
480 adfac1=adfac*(vbar(i,jend+1,kinp)+ubar_xs)
481 adfac2=adfac*(drhs(i,jend+1)+drhs(i,jend))
482 ad_drhs(i,jend+1)=ad_drhs(i,jend+1)+adfac1
483 ad_drhs(i,jend )=ad_drhs(i,jend )+adfac1
484 ad_vbar(i,jend+1,kinp)=ad_vbar(i,jend+1,kinp)+adfac2
485 ad_my_ubar_xs=ad_my_ubar_xs+adfac2
486 ad_dvom(i,jend+1)=0.0_r8
487 END DO
488 END IF
489 END IF
490
491 IF (ad_volcons(isouth,ng)) THEN
492 IF (domain(ng)%Southern_Edge(tile)) THEN
493 DO i=-2+i_range+1
494# ifdef MASKING
495!^ tl_Dvom(i,Jstr)=tl_Dvom(i,Jstr)*vmask(i,Jstr)
496!^
497 ad_dvom(i,jstr)=ad_dvom(i,jstr)*vmask(i,jstr)
498# endif
499!^ tl_Dvom(i,Jstr)=0.5_r8* &
500!^ & ((tl_Drhs(i,Jstr)+tl_Drhs(i,Jstr-1))* &
501!^ & (vbar(i,Jstr,kinp)-ubar_xs)+ &
502!^ & (Drhs(i,Jstr)+Drhs(i,Jstr-1))* &
503!^ & (tl_vbar(i,Jstr,kinp)-tl_ubar_xs))* &
504!^ & om_v(i,Jstr)
505!^
506 adfac=0.5_r8*om_v(i,jstr)*ad_dvom(i,jstr)
507 adfac1=adfac*(vbar(i,jstr,kinp)-ubar_xs)
508 adfac2=adfac*(drhs(i,jstr)+drhs(i,jstr-1))
509 ad_drhs(i,jstr-1)=ad_drhs(i,jstr-1)+adfac1
510 ad_drhs(i,jstr )=ad_drhs(i,jstr )+adfac1
511 ad_vbar(i,jstr,kinp)=ad_vbar(i,jstr,kinp)+adfac2
512 ad_my_ubar_xs=ad_my_ubar_xs-adfac2
513 ad_dvom(i,jstr)=0.0_r8
514 END DO
515 END IF
516 END IF
517
518 IF (ad_volcons(ieast,ng)) THEN
519 IF (domain(ng)%Eastern_Edge(tile)) THEN
520 DO j=-2+j_range+1
521# ifdef MASKING
522!^ tl_Duon(Iend+1,j)=tl_Duon(Iend+1,j)*umask(Iend+1,j)
523!^
524 ad_duon(iend+1,j)=ad_duon(iend+1,j)*umask(iend+1,j)
525# endif
526!^ tl_Duon(Iend+1,j)=0.5_r8* &
527!^ & ((tl_Drhs(Iend+1,j)+tl_Drhs(Iend,j))* &
528!^ & (ubar(Iend+1,j,kinp)+ubar_xs)+ &
529!^ & (Drhs(Iend+1,j)+Drhs(Iend,j))* &
530!^ & (tl_ubar(Iend+1,j,kinp)+tl_ubar_xs))* &
531!^ & on_u(Iend+1,j)
532!^
533 adfac=0.5_r8*on_u(iend+1,j)*ad_duon(iend+1,j)
534 adfac1=adfac*(ubar(iend+1,j,kinp)+ubar_xs)
535 adfac2=adfac*(drhs(iend+1,j)+drhs(iend,j))
536 ad_drhs(iend ,j)=ad_drhs(iend ,j)+adfac1
537 ad_drhs(iend+1,j)=ad_drhs(iend+1,j)+adfac1
538 ad_ubar(iend+1,j,kinp)=ad_ubar(iend+1,j,kinp)+adfac2
539 ad_my_ubar_xs=ad_my_ubar_xs+adfac2
540 ad_duon(iend+1,j)=0.0_r8
541 END DO
542 END IF
543 END IF
544
545 IF (ad_volcons(iwest,ng)) THEN
546 IF (domain(ng)%Western_Edge(tile)) THEN
547 DO j=-2+j_range+1
548# ifdef MASKING
549!^ tl_Duon(Istr,j)=tl_Duon(Istr,j)*umask(Istr,j)
550!^
551 ad_duon(istr,j)=ad_duon(istr,j)*umask(istr,j)
552# endif
553!^ tl_Duon(Istr,j)=0.5_r8* &
554!^ & ((tl_Drhs(Istr,j)+tl_Drhs(Istr-1,j))* &
555!^ & (ubar(Istr,j,kinp)-ubar_xs)+ &
556!^ & (Drhs(Istr,j)+Drhs(Istr-1,j))* &
557!^ & (tl_ubar(Istr,j,kinp)-tl_ubar_xs))* &
558!^ & on_u(Istr,j)
559!^
560 adfac=0.5_r8*on_u(istr,j)*ad_duon(istr,j)
561 adfac1=adfac*(ubar(istr,j,kinp)-ubar_xs)
562 adfac2=adfac*(drhs(istr,j)+drhs(istr-1,j))
563 ad_drhs(istr-1,j)=ad_drhs(istr-1,j)+adfac1
564 ad_drhs(istr ,j)=ad_drhs(istr ,j)+adfac1
565 ad_ubar(istr,j,kinp)=ad_ubar(istr,j,kinp)+adfac2
566 ad_my_ubar_xs=ad_my_ubar_xs-adfac2
567 ad_duon(istr,j)=0.0_r8
568 END DO
569 END IF
570 END IF
571
572# undef I_RANGE
573# undef J_RANGE
574!
575!-----------------------------------------------------------------------
576! Perform global summation and compute correction velocity.
577!-----------------------------------------------------------------------
578!
579 IF (any(ad_volcons(:,ng))) THEN
580# ifdef DISTRIBUTE
581 nsub=1 ! distributed-memory
582# else
583 IF (domain(ng)%SouthWest_Corner(tile).and. &
584 & domain(ng)%NorthEast_Corner(tile)) THEN
585 nsub=1 ! non-tiled application
586 ELSE
587 nsub=ntilex(ng)*ntilee(ng) ! tiled application
588 END IF
589# endif
590!$OMP CRITICAL (AD_OBC_VOLUME)
591 IF (tile_count.eq.0) THEN
592 adfac3=0.0_r8
593 END IF
594 adfac3=adfac3+ad_my_ubar_xs
595 tile_count=tile_count+1
596 IF (tile_count.eq.nsub) THEN
597 tile_count=0
598# ifdef DISTRIBUTE
599 rbuffer=adfac3
600 op_handle='SUM'
601 CALL mp_reduce (ng, iadm, 1, rbuffer, op_handle)
602 adfac3=rbuffer
603# endif
604 IF (iif(ng).eq.nfast(ng)+1) THEN
605 ad_ubar_xs=ad_ubar_xs+adfac3
606 ELSE
607 ad_ubar_xs=adfac3
608 ENDIF
609 END IF
610!$OMP END CRITICAL (AD_OBC_VOLUME)
611 END IF
612
613 RETURN
614 END SUBROUTINE ad_set_duv_bc_tile
615!
616!***********************************************************************
617 SUBROUTINE ad_conserve_mass_tile (ng, tile, &
618 & LBi, UBi, LBj, UBj, &
619 & IminS, ImaxS, JminS, JmaxS, &
620 & kinp, &
621# ifdef MASKING
622 & umask, vmask, &
623# endif
624 & ad_ubar, ad_vbar)
625!***********************************************************************
626!
627 USE mod_param
628 USE mod_scalars
629!
630! Imported variable declarations.
631!
632 integer, intent(in) :: ng, tile
633 integer, intent(in) :: LBi, UBi, LBj, UBj
634 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
635 integer, intent(in) :: kinp
636!
637# ifdef ASSUMED_SHAPE
638# ifdef MASKING
639 real(r8), intent(in) :: umask(LBi:,LBj:)
640 real(r8), intent(in) :: vmask(LBi:,LBj:)
641# endif
642 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
643 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
644# else
645# ifdef MASKING
646 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
647 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
648# endif
649 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
650 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
651# endif
652!
653! Local variable declarations.
654!
655 integer :: i, j
656
657# include "set_bounds.h"
658!
659!-----------------------------------------------------------------------
660! Corrects velocities across the open boundaries to enforce global
661! mass conservation constraint.
662!-----------------------------------------------------------------------
663!
664 IF (ad_volcons(inorth,ng)) THEN
665 IF (domain(ng)%Northern_Edge(tile)) THEN
666 DO i=istr,iend
667# ifdef MASKING
668!^ vbar(i,Jend+1,kinp)=vbar(i,Jend+1,kinp)* &
669!^ & vmask(i,Jend+1)
670!^
671 ad_vbar(i,jend+1,kinp)=ad_vbar(i,jend+1,kinp)* &
672 & vmask(i,jend+1)
673# endif
674!^ tl_vbar(i,Jend+1,kinp)=(tl_vbar(i,Jend+1,kinp)+tl_ubar_xs)
675!^
676 ad_ubar_xs=ad_ubar_xs+ad_vbar(i,jend+1,kinp)
677 END DO
678 END IF
679 END IF
680
681 IF (ad_volcons(isouth,ng)) THEN
682 IF (domain(ng)%Southern_Edge(tile)) THEN
683 DO i=istr,iend
684# ifdef MASKING
685!^ tl_vbar(i,Jstr,kinp)=tl_vbar(i,Jstr,kinp)* &
686!^ & vmask(i,Jstr)
687!^
688 ad_vbar(i,jstr,kinp)=ad_vbar(i,jstr,kinp)* &
689 & vmask(i,jstr)
690# endif
691!^ tl_vbar(i,Jstr,kinp)=(tl_vbar(i,Jstr,kinp)-tl_ubar_xs)
692!^
693 ad_ubar_xs=ad_ubar_xs-ad_vbar(i,jstr,kinp)
694 END DO
695 END IF
696 END IF
697
698 IF (ad_volcons(ieast,ng)) THEN
699 IF (domain(ng)%Eastern_Edge(tile)) THEN
700 DO j=jstr,jend
701# ifdef MASKING
702!^ tl_ubar(Iend+1,j,kinp)=tl_ubar(Iend+1,j,kinp)* &
703!^ & umask(Iend+1,j)
704!^
705 ad_ubar(iend+1,j,kinp)=ad_ubar(iend+1,j,kinp)* &
706 & umask(iend+1,j)
707# endif
708!^ tl_ubar(Iend+1,j,kinp)=tl_ubar(Iend+1,j,kinp)+tl_ubar_xs
709!^
710 ad_ubar_xs=ad_ubar_xs+ad_ubar(iend+1,j,kinp)
711 END DO
712 END IF
713 END IF
714
715 IF (ad_volcons(iwest,ng)) THEN
716 IF (domain(ng)%Western_Edge(tile)) THEN
717 DO j=jstr,jend
718# ifdef MASKING
719!^ tl_ubar(Istr,j,kinp)=tl_ubar(Istr,j,kinp)* &
720!^ & umask(Istr,j)
721!^
722 ad_ubar(istr,j,kinp)=ad_ubar(istr,j,kinp)* &
723 & umask(istr,j)
724# endif
725!^ tl_ubar(Istr,j,kinp)=tl_ubar(Istr,j,kinp)-tl_ubar_xs
726!^
727 ad_ubar_xs=ad_ubar_xs-ad_ubar(istr,j,kinp)
728 END DO
729 END IF
730 END IF
731
732 RETURN
733 END SUBROUTINE ad_conserve_mass_tile
734#endif
735 END MODULE ad_obc_volcons_mod
distribute_mod::mp_reduce
Definition distribute.F:113
ad_obc_volcons_mod
Definition ad_obc_volcons.F:2
ad_obc_volcons_mod::ad_set_duv_bc_tile
subroutine, public ad_set_duv_bc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kinp, umask, vmask, om_v, on_u, ubar, vbar, ad_ubar, ad_vbar, drhs, duon, dvom, ad_drhs, ad_duon, ad_dvom)
Definition ad_obc_volcons.F:341
ad_obc_volcons_mod::ad_conserve_mass_tile
subroutine ad_conserve_mass_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kinp, umask, vmask, ad_ubar, ad_vbar)
Definition ad_obc_volcons.F:625
ad_obc_volcons_mod::ad_obc_flux
subroutine ad_obc_flux(ng, tile, kinp)
Definition ad_obc_volcons.F:27
ad_obc_volcons_mod::ad_obc_flux_tile
subroutine, public ad_obc_flux_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kinp, umask, vmask, h, ad_h, om_v, on_u, ubar, vbar, zeta, ad_ubar, ad_vbar, ad_zeta)
Definition ad_obc_volcons.F:75
distribute_mod
Definition distribute.F:3
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_parallel
Definition mod_parallel.F:2
mod_parallel::tile_count
integer tile_count
Definition mod_parallel.F:89
mod_param
Definition mod_param.F:2
mod_param::ntilex
integer, dimension(:), allocatable ntilex
Definition mod_param.F:685
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::ntilee
integer, dimension(:), allocatable ntilee
Definition mod_param.F:686
mod_scalars
Definition mod_scalars.F:2
mod_scalars::ad_bc_flux
real(dp) ad_bc_flux
Definition mod_scalars.F:1470
mod_scalars::ad_volcons
logical, dimension(:,:), allocatable ad_volcons
Definition mod_scalars.F:517
mod_scalars::ubar_xs
real(dp) ubar_xs
Definition mod_scalars.F:1462
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::bc_area
real(dp) bc_area
Definition mod_scalars.F:1460
mod_scalars::nfast
integer, dimension(:), allocatable nfast
Definition mod_scalars.F:259
mod_scalars::ad_bc_area
real(dp) ad_bc_area
Definition mod_scalars.F:1469
mod_scalars::ad_ubar_xs
real(dp) ad_ubar_xs
Definition mod_scalars.F:1471
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::iif
integer, dimension(:), allocatable iif
Definition mod_scalars.F:250
mod_stepping
Definition mod_stepping.F:2
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::ad_mp_exchange2d
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4058