ROMS
Loading...
Searching...
No Matches
ad_step2d_LF_AM3.h
Go to the documentation of this file.
1#undef DEBUG
2 MODULE ad_step2d_mod
3!
4!git $Id$
5!=======================================================================
6! !
7! Adjoint shallow-water primitive equations predictor (Leap-frog) !
8! and corrector (Adams-Moulton) time-stepping engine. !
9! !
10!=======================================================================
11!
12 implicit none
13!
14 PRIVATE
15 PUBLIC :: ad_step2d
16!
17 CONTAINS
18!
19!***********************************************************************
20 SUBROUTINE ad_step2d (ng, tile)
21!***********************************************************************
22!
23 USE mod_param
24 USE mod_ncparam
25#ifdef SOLVE3D
26 USE mod_coupling
27#endif
28#ifdef DIAGNOSTICS_UV
29!! USE mod_diags
30#endif
31 USE mod_forces
32 USE mod_grid
33#if defined UV_VIS2 || defined UV_VIS4 || defined WEC_MELLOR
34 USE mod_mixing
35#endif
36 USE mod_ocean
37#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET && \
38 defined solve3d
39 USE mod_sedbed
40#endif
41 USE mod_stepping
42!
43! Imported variable declarations.
44!
45 integer, intent(in) :: ng, tile
46!
47! Local variable declarations.
48!
49 character (len=*), parameter :: MyFile = &
50 & __FILE__
51!
52#include "tile.h"
53
54#ifdef PROFILE
55 CALL wclock_on (ng, iadm, 9, __line__, myfile)
56#endif
57 CALL ad_step2d_tile (ng, tile, &
58 & lbi, ubi, lbj, ubj, n(ng), &
59 & imins, imaxs, jmins, jmaxs, &
60 & krhs(ng), kstp(ng), knew(ng), &
61#ifdef SOLVE3D
62 & nstp(ng), nnew(ng), &
63#endif
64#ifdef MASKING
65 & grid(ng) % pmask, grid(ng) % rmask, &
66 & grid(ng) % umask, grid(ng) % vmask, &
67#endif
68#ifdef WET_DRY_NOT_YET
69 & grid(ng) % pmask_wet, grid(ng) % pmask_full, &
70 & grid(ng) % rmask_wet, grid(ng) % rmask_full, &
71 & grid(ng) % umask_wet, grid(ng) % umask_full, &
72 & grid(ng) % vmask_wet, grid(ng) % vmask_full, &
73# ifdef SOLVE3D
74 & grid(ng) % rmask_wet_avg, &
75# endif
76#endif
77 & grid(ng) % fomn, &
78 & grid(ng) % h, grid(ng) % ad_h, &
79 & grid(ng) % om_u, grid(ng) % om_v, &
80 & grid(ng) % on_u, grid(ng) % on_v, &
81 & grid(ng) % omn, &
82 & grid(ng) % pm, grid(ng) % pn, &
83#if defined CURVGRID && defined UV_ADV
84 & grid(ng) % dndx, grid(ng) % dmde, &
85#endif
86#if defined UV_VIS2 || defined UV_VIS4
87 & grid(ng) % pmon_r, grid(ng) % pnom_r, &
88 & grid(ng) % pmon_p, grid(ng) % pnom_p, &
89 & grid(ng) % om_r, grid(ng) % on_r, &
90 & grid(ng) % om_p, grid(ng) % on_p, &
91# ifdef UV_VIS2
92 & mixing(ng) % visc2_p, mixing(ng) % visc2_r,&
93# endif
94# ifdef UV_VIS4
95 & mixing(ng) % visc4_p, mixing(ng) % visc4_r,&
96# endif
97#endif
98#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
99 & sedbed(ng) % ad_bed_thick, &
100#endif
101#ifdef WEC_MELLOR
102 & mixing(ng) % ad_rustr2d, &
103 & mixing(ng) % ad_rvstr2d, &
104 & ocean(ng) % ad_rulag2d, &
105 & ocean(ng) % ad_rvlag2d, &
106 & ocean(ng) % ubar_stokes, &
107 & ocean(ng) % ad_ubar_stokes, &
108 & ocean(ng) % vbar_stokes, &
109 & ocean(ng) % ad_vbar_stokes, &
110#endif
111#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
112 & ocean(ng) % eq_tide, &
113 & ocean(ng) % ad_eq_tide, &
114#endif
115#ifndef SOLVE3D
116 & forces(ng) % ad_sustr, &
117 & forces(ng) % ad_svstr, &
118 & forces(ng) % ad_bustr, &
119 & forces(ng) % ad_bvstr, &
120# ifdef ATM_PRESS
121 & forces(ng) % Pair, &
122# endif
123#else
124# ifdef VAR_RHO_2D_NOT_YET
125 & coupling(ng) % rhoA, &
126 & coupling(ng) % ad_rhoA, &
127 & coupling(ng) % rhoS, &
128 & coupling(ng) % ad_rhoS, &
129# endif
130 & coupling(ng) % ad_DU_avg1, &
131 & coupling(ng) % ad_DU_avg2, &
132 & coupling(ng) % ad_DV_avg1, &
133 & coupling(ng) % ad_DV_avg2, &
134 & coupling(ng) % Zt_avg1, &
135 & coupling(ng) % ad_Zt_avg1, &
136 & coupling(ng) % ad_rufrc, &
137 & coupling(ng) % ad_rvfrc, &
138 & ocean(ng) % ad_ru, &
139 & ocean(ng) % ad_rv, &
140#endif
141#ifdef DIAGNOSTICS_UV
142!! & DIAGS(ng) % DiaU2wrk, DIAGS(ng) % DiaV2wrk,&
143!! & DIAGS(ng) % DiaRUbar, DIAGS(ng) % DiaRVbar,&
144# ifdef SOLVE3D
145!! & DIAGS(ng) % DiaU2int, DIAGS(ng) % DiaV2int,&
146!! & DIAGS(ng) % DiaRUfrc, DIAGS(ng) % DiaRVfrc,&
147# endif
148#endif
149#ifndef SOLVE3D
150 & ocean(ng) % ad_ubar_sol, &
151 & ocean(ng) % ad_vbar_sol, &
152 & ocean(ng) % ad_zeta_sol, &
153#endif
154 & ocean(ng) % rubar, ocean(ng) % ad_rubar,&
155 & ocean(ng) % rvbar, ocean(ng) % ad_rvbar,&
156 & ocean(ng) % rzeta, ocean(ng) % ad_rzeta,&
157 & ocean(ng) % ubar, ocean(ng) % ad_ubar, &
158 & ocean(ng) % vbar, ocean(ng) % ad_vbar, &
159 & ocean(ng) % zeta, ocean(ng) % ad_zeta)
160#ifdef PROFILE
161 CALL wclock_off (ng, iadm, 9, __line__, myfile)
162#endif
163!
164 RETURN
165 END SUBROUTINE ad_step2d
166!
167!***********************************************************************
168 SUBROUTINE ad_step2d_tile (ng, tile, &
169 & LBi, UBi, LBj, UBj, UBk, &
170 & IminS, ImaxS, JminS, JmaxS, &
171 & krhs, kstp, knew, &
172#ifdef SOLVE3D
173 & nstp, nnew, &
174#endif
175#ifdef MASKING
176 & pmask, rmask, umask, vmask, &
177#endif
178#ifdef WET_DRY_NOT_YET
179 & pmask_wet, pmask_full, &
180 & rmask_wet, rmask_full, &
181 & umask_wet, umask_full, &
182 & vmask_wet, vmask_full, &
183# ifdef SOLVE3D
184 & rmask_wet_avg, &
185# endif
186#endif
187 & fomn, &
188 & h, ad_h, &
189 & om_u, om_v, on_u, on_v, omn, pm, pn, &
190#if defined CURVGRID && defined UV_ADV
191 & dndx, dmde, &
192#endif
193#if defined UV_VIS2 || defined UV_VIS4
194 & pmon_r, pnom_r, pmon_p, pnom_p, &
195 & om_r, on_r, om_p, on_p, &
196# ifdef UV_VIS2
197 & visc2_p, visc2_r, &
198# endif
199# ifdef UV_VIS4
200 & visc4_p, visc4_r, &
201# endif
202#endif
203#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
204 & ad_bed_thick, &
205#endif
206#ifdef WEC_MELLOR
207 & ad_rustr2d, ad_rvstr2d, &
208 & ad_rulag2d, ad_rvlag2d, &
209 & ubar_stokes, ad_ubar_stokes, &
210 & vbar_stokes, ad_vbar_stokes, &
211#endif
212#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
213 & eq_tide, ad_eq_tide, &
214#endif
215#ifndef SOLVE3D
216 & ad_sustr, ad_svstr, &
217 & ad_bustr, ad_bvstr, &
218# ifdef ATM_PRESS
219 & Pair, &
220# endif
221#else
222# ifdef VAR_RHO_2D_NOT_YET
223 & rhoA, ad_rhoA, rhoS, ad_rhoS, &
224# endif
225 & ad_DU_avg1, ad_DU_avg2, &
226 & ad_DV_avg1, ad_DV_avg2, &
227 & Zt_avg1, ad_Zt_avg1, &
228 & ad_rufrc, ad_rvfrc, &
229 & ad_ru, ad_rv, &
230#endif
231#ifdef DIAGNOSTICS_UV
232!! & DiaU2wrk, DiaV2wrk, &
233!! & DiaRUbar, DiaRVbar, &
234# ifdef SOLVE3D
235!! & DiaU2int, DiaV2int, &
236!! & DiaRUfrc, DiaRVfrc, &
237# endif
238#endif
239#ifndef SOLVE3D
240 & ad_ubar_sol, ad_vbar_sol, &
241 & ad_zeta_sol, &
242#endif
243 & rubar, ad_rubar, &
244 & rvbar, ad_rvbar, &
245 & rzeta, ad_rzeta, &
246 & ubar, ad_ubar, &
247 & vbar, ad_vbar, &
248 & zeta, ad_zeta)
249!***********************************************************************
250!
251 USE mod_param
252 USE mod_clima
253 USE mod_ncparam
254 USE mod_scalars
255#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
256 USE mod_sedbed
257#endif
258 USE mod_sources
259!
260 USE ad_exchange_2d_mod
261 USE exchange_2d_mod
262#ifdef DISTRIBUTE
263 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
264 USE mp_exchange_mod, ONLY : mp_exchange2d
265#endif
266 USE obc_volcons_mod
267 USE ad_obc_volcons_mod
268 USE ad_u2dbc_mod, ONLY : ad_u2dbc_tile
269 USE ad_v2dbc_mod, ONLY : ad_v2dbc_tile
270 USE ad_zetabc_mod, ONLY : ad_zetabc_tile
271#ifdef WET_DRY_NOT_YET
272!^ USE wetdry_mod, ONLY : wetdry_tile
273#endif
274!
275! Imported variable declarations.
276!
277 integer, intent(in) :: ng, tile
278 integer, intent(in) :: LBi, UBi, LBj, UBj, UBk
279 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
280 integer, intent(in) :: krhs, kstp, knew
281#ifdef SOLVE3D
282 integer, intent(in) :: nstp, nnew
283#endif
284!
285#ifdef ASSUMED_SHAPE
286# ifdef MASKING
287 real(r8), intent(in) :: pmask(LBi:,LBj:)
288 real(r8), intent(in) :: rmask(LBi:,LBj:)
289 real(r8), intent(in) :: umask(LBi:,LBj:)
290 real(r8), intent(in) :: vmask(LBi:,LBj:)
291# endif
292 real(r8), intent(in) :: fomn(LBi:,LBj:)
293 real(r8), intent(in) :: h(LBi:,LBj:)
294 real(r8), intent(in) :: om_u(LBi:,LBj:)
295 real(r8), intent(in) :: om_v(LBi:,LBj:)
296 real(r8), intent(in) :: on_u(LBi:,LBj:)
297 real(r8), intent(in) :: on_v(LBi:,LBj:)
298 real(r8), intent(in) :: omn(LBi:,LBj:)
299 real(r8), intent(in) :: pm(LBi:,LBj:)
300 real(r8), intent(in) :: pn(LBi:,LBj:)
301# if defined CURVGRID && defined UV_ADV
302 real(r8), intent(in) :: dndx(LBi:,LBj:)
303 real(r8), intent(in) :: dmde(LBi:,LBj:)
304# endif
305# if defined UV_VIS2 || defined UV_VIS4
306 real(r8), intent(in) :: pmon_r(LBi:,LBj:)
307 real(r8), intent(in) :: pnom_r(LBi:,LBj:)
308 real(r8), intent(in) :: pmon_p(LBi:,LBj:)
309 real(r8), intent(in) :: pnom_p(LBi:,LBj:)
310 real(r8), intent(in) :: om_r(LBi:,LBj:)
311 real(r8), intent(in) :: on_r(LBi:,LBj:)
312 real(r8), intent(in) :: om_p(LBi:,LBj:)
313 real(r8), intent(in) :: on_p(LBi:,LBj:)
314# ifdef UV_VIS2
315 real(r8), intent(in) :: visc2_p(LBi:,LBj:)
316 real(r8), intent(in) :: visc2_r(LBi:,LBj:)
317# endif
318# ifdef UV_VIS4
319 real(r8), intent(in) :: visc4_p(LBi:,LBj:)
320 real(r8), intent(in) :: visc4_r(LBi:,LBj:)
321# endif
322# endif
323# ifdef WEC_MELLOR
324 real(r8), intent(in) :: ubar_stokes(LBi:,LBj:)
325 real(r8), intent(in) :: vbar_stokes(LBi:,LBj:)
326# endif
327 real(r8), intent(in) :: rubar(LBi:,LBj:,:)
328 real(r8), intent(in) :: rvbar(LBi:,LBj:,:)
329 real(r8), intent(in) :: rzeta(LBi:,LBj:,:)
330 real(r8), intent(in) :: ubar(LBi:,LBj:,:)
331 real(r8), intent(in) :: vbar(LBi:,LBj:,:)
332 real(r8), intent(in) :: zeta(LBi:,LBj:,:)
333# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
334 real(r8), intent(in) :: eq_tide(LBi:,LBj:)
335# endif
336# if !defined SOLVE3D && defined ATM_PRESS
337 real(r8), intent(in) :: Pair(LBi:,LBj:)
338# endif
339# ifdef SOLVE3D
340# if defined VAR_RHO_2D_NOT_YET
341 real(r8), intent(in) :: rhoA(LBi:,LBj:)
342 real(r8), intent(in) :: rhoS(LBi:,LBj:)
343# endif
344 real(r8), intent(in) :: Zt_avg1(LBi:,LBj:)
345
346 real(r8), intent(inout) :: ad_DU_avg1(LBi:,LBj:)
347 real(r8), intent(inout) :: ad_DU_avg2(LBi:,LBj:)
348 real(r8), intent(inout) :: ad_DV_avg1(LBi:,LBj:)
349 real(r8), intent(inout) :: ad_DV_avg2(LBi:,LBj:)
350 real(r8), intent(inout) :: ad_Zt_avg1(LBi:,LBj:)
351# if defined VAR_RHO_2D_NOT_YET
352 real(r8), intent(inout) :: ad_rhoA(LBi:,LBj:)
353 real(r8), intent(inout) :: ad_rhoS(LBi:,LBj:)
354# endif
355 real(r8), intent(inout) :: ad_rufrc(LBi:,LBj:)
356 real(r8), intent(inout) :: ad_rvfrc(LBi:,LBj:)
357 real(r8), intent(inout) :: ad_ru(LBi:,LBj:,0:,:)
358 real(r8), intent(inout) :: ad_rv(LBi:,LBj:,0:,:)
359# else
360 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
361 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
362 real(r8), intent(inout) :: ad_bustr(LBi:,LBj:)
363 real(r8), intent(inout) :: ad_bvstr(LBi:,LBj:)
364# endif
365# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
366 real(r8), intent(inout) :: ad_bed_thick(LBi:,LBj:,:)
367# endif
368# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
369 real(r8), intent(inout) :: ad_eq_tide(LBi:,LBj:)
370# endif
371# ifdef WEC_MELLOR
372 real(r8), intent(inout) :: ad_rustr2d(LBi:,LBj:)
373 real(r8), intent(inout) :: ad_rvstr2d(LBi:,LBj:)
374 real(r8), intent(inout) :: ad_rulag2d(LBi:,LBj:)
375 real(r8), intent(inout) :: ad_rvlag2d(LBi:,LBj:)
376 real(r8), intent(inout) :: ad_ubar_stokes(LBi:,LBj:)
377 real(r8), intent(inout) :: ad_vbar_stokes(LBi:,LBj:)
378# endif
379# ifdef WET_DRY_NOT_YET
380 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
381 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
382 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
383 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
384
385 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
386 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
387 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
388 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
389# ifdef SOLVE3D
390 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
391# endif
392# endif
393# ifdef DIAGNOSTICS_UV
394!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
395!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
396!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
397!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
398# ifdef SOLVE3D
399!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
400!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
401!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
402!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
403# endif
404# endif
405 real(r8), intent(inout) :: ad_h(LBi:,LBj:)
406 real(r8), intent(inout) :: ad_rubar(LBi:,LBj:,:)
407 real(r8), intent(inout) :: ad_rvbar(LBi:,LBj:,:)
408 real(r8), intent(inout) :: ad_rzeta(LBi:,LBj:,:)
409 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
410 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
411 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
412# ifndef SOLVE3D
413 real(r8), intent(out) :: ad_ubar_sol(LBi:,LBj:)
414 real(r8), intent(out) :: ad_vbar_sol(LBi:,LBj:)
415 real(r8), intent(out) :: ad_zeta_sol(LBi:,LBj:)
416# endif
417
418#else
419
420# ifdef MASKING
421 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
422 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
423 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
424 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
425# endif
426 real(r8), intent(in) :: fomn(LBi:UBi,LBj:UBj)
427 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
428 real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj)
429 real(r8), intent(in) :: om_v(LBi:UBi,LBj:UBj)
430 real(r8), intent(in) :: on_u(LBi:UBi,LBj:UBj)
431 real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj)
432 real(r8), intent(in) :: omn(LBi:UBi,LBj:UBj)
433 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
434 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
435# if defined CURVGRID && defined UV_ADV
436 real(r8), intent(in) :: dndx(LBi:UBi,LBj:UBj)
437 real(r8), intent(in) :: dmde(LBi:UBi,LBj:UBj)
438# endif
439# if defined UV_VIS2 || defined UV_VIS4
440 real(r8), intent(in) :: pmon_r(LBi:UBi,LBj:UBj)
441 real(r8), intent(in) :: pnom_r(LBi:UBi,LBj:UBj)
442 real(r8), intent(in) :: pmon_p(LBi:UBi,LBj:UBj)
443 real(r8), intent(in) :: pnom_p(LBi:UBi,LBj:UBj)
444 real(r8), intent(in) :: om_r(LBi:UBi,LBj:UBj)
445 real(r8), intent(in) :: on_r(LBi:UBi,LBj:UBj)
446 real(r8), intent(in) :: om_p(LBi:UBi,LBj:UBj)
447 real(r8), intent(in) :: on_p(LBi:UBi,LBj:UBj)
448# ifdef UV_VIS2
449 real(r8), intent(in) :: visc2_p(LBi:UBi,LBj:UBj)
450 real(r8), intent(in) :: visc2_r(LBi:UBi,LBj:UBj)
451# endif
452# ifdef UV_VIS4
453 real(r8), intent(in) :: visc4_p(LBi:UBi,LBj:UBj)
454 real(r8), intent(in) :: visc4_r(LBi:UBi,LBj:UBj)
455# endif
456# endif
457# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
458 real(r8), intent(inout) :: ad_bed_thick(LBi:UBi,LBj:UBj,3)
459# endif
460# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
461 real(r8), intent(in) :: eq_tide(LBi:UBi,LBj:UBj)
462# endif
463# ifdef WEC_MELLOR
464 real(r8), intent(in) :: ubar_stokes(LBi:UBi,LBj:UBj)
465 real(r8), intent(in) :: vbar_stokes(LBi:UBi,LBj:UBj)
466# endif
467 real(r8), intent(in) :: rubar(LBi:UBi,LBj:UBj,2)
468 real(r8), intent(in) :: rvbar(LBi:UBi,LBj:UBj,2)
469 real(r8), intent(in) :: rzeta(LBi:UBi,LBj:UBj,2)
470 real(r8), intent(in) :: ubar(LBi:UBi,LBj:UBj,:)
471 real(r8), intent(in) :: vbar(LBi:UBi,LBj:UBj,:)
472 real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,:)
473# if !defined SOLVE3D && defined ATM_PRESS
474 real(r8), intent(in) :: Pair(LBi:UBi,LBj:UBj)
475# endif
476# ifdef SOLVE3D
477# ifdef VAR_RHO_2D_NOT_YET
478 real(r8), intent(in) :: rhoA(LBi:UBi,LBj:UBj)
479 real(r8), intent(in) :: rhoS(LBi:UBi,LBj:UBj)
480# endif
481 real(r8), intent(in) :: Zt_avg1(LBi:UBi,LBj:UBj)
482
483 real(r8), intent(inout) :: ad_DU_avg1(LBi:UBi,LBj:UBj)
484 real(r8), intent(inout) :: ad_DU_avg2(LBi:UBi,LBj:UBj)
485 real(r8), intent(inout) :: ad_DV_avg1(LBi:UBi,LBj:UBj)
486 real(r8), intent(inout) :: ad_DV_avg2(LBi:UBi,LBj:UBj)
487 real(r8), intent(inout) :: ad_Zt_avg1(LBi:UBi,LBj:UBj)
488# if defined VAR_RHO_2D_NOT_YET
489 real(r8), intent(inout) :: ad_rhoA(LBi:UBi,LBj:UBj)
490 real(r8), intent(inout) :: ad_rhoS(LBi:UBi,LBj:UBj)
491# endif
492 real(r8), intent(inout) :: ad_rufrc(LBi:UBi,LBj:UBj)
493 real(r8), intent(inout) :: ad_rvfrc(LBi:UBi,LBj:UBj)
494 real(r8), intent(inout) :: ad_ru(LBi:UBi,LBj:UBj,0:UBk,2)
495 real(r8), intent(inout) :: ad_rv(LBi:UBi,LBj:UBj,0:UBk,2)
496# else
497 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
498 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
499 real(r8), intent(inout) :: ad_bustr(LBi:UBi,LBj:UBj)
500 real(r8), intent(inout) :: ad_bvstr(LBi:UBi,LBj:UBj)
501# endif
502# ifdef WEC_MELLOR
503 real(r8), intent(inout) :: ad_rustr2d(LBi:UBi,LBj:UBj)
504 real(r8), intent(inout) :: ad_rvstr2d(LBi:UBi,LBj:UBj)
505 real(r8), intent(inout) :: ad_rulag2d(LBi:UBi,LBj:UBj)
506 real(r8), intent(inout) :: ad_rvlag2d(LBi:UBi,LBj:UBj)
507 real(r8), intent(inout) :: ad_ubar_stokes(LBi:UBi,LBj:UBj)
508 real(r8), intent(inout) :: ad_vbar_stokes(LBi:UBi,LBj:UBj)
509# endif
510# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
511 real(r8), intent(inout) :: ad_eq_tide(LBi:UBi,LBj:UBj)
512# endif
513# ifdef WET_DRY_NOT_YET
514 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
515 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
516 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
517 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
518
519 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
520 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
521 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
522 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
523# ifdef SOLVE3D
524 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
525# endif
526# endif
527# ifdef DIAGNOSTICS_UV
528!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
529!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
530!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
531!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
532# ifdef SOLVE3D
533!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
534!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
535!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
536!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
537# endif
538# endif
539 real(r8), intent(inout) :: ad_h(LBi:UBi,LBj:UBj)
540 real(r8), intent(inout) :: ad_rubar(LBi:UBi,LBj:UBj,2)
541 real(r8), intent(inout) :: ad_rvbar(LBi:UBi,LBj:UBj,2)
542 real(r8), intent(inout) :: ad_rzeta(LBi:UBi,LBj:UBj,2)
543 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
544 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
545 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
546# ifndef SOLVE3D
547 real(r8), intent(out) :: ad_ubar_sol(LBi:UBi,LBj:UBj)
548 real(r8), intent(out) :: ad_vbar_sol(LBi:UBi,LBj:UBj)
549 real(r8), intent(out) :: ad_zeta_sol(LBi:UBi,LBj:UBj)
550# endif
551#endif
552!
553! Local variable declarations.
554!
555 logical :: CORRECTOR_2D_STEP
556!
557 integer :: i, is, j, ptsk
558#ifdef DIAGNOSTICS_UV
559!! integer :: idiag
560#endif
561!
562 real(r8) :: cff, cff1, cff2, cff3, cff4, cff5, cff6, cff7
563 real(r8) :: fac, fac1, fac2, fac3
564 real(r8) :: ad_cff, ad_cff1, ad_cff2, ad_cff3, ad_cff4
565 real(r8) :: ad_fac, ad_fac1
566 real(r8) :: adfac, adfac1, adfac2, adfac3, adfac4
567!
568 real(r8), parameter :: IniVal = 0.0_r8
569!
570 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
571 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
572 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
573 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
574 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
575 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
576 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
577#ifdef WEC_MELLOR
578 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
579 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
580#endif
581#ifdef UV_VIS4
582 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: LapU
583 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: LapV
584 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
585 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
586 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
587 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
588#endif
589 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
590 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzeta
591 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzeta2
592#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
593 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzetaSA
594#endif
595 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_ubar
596 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_vbar
597 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_zeta
598 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
599 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
600#ifdef WET_DRY_NOT_YET
601!^ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
602#endif
603#ifdef DIAGNOSTICS_UV
604!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
605!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
606!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,
607!! & NDM2d-1) :: DiaU2rhs
608!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,
609!! & NDM2d-1) :: DiaV2rhs
610#endif
611
612 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dgrad
613 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dnew
614 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs
615 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs_p
616 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dstp
617 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUon
618 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVom
619#ifdef WEC_MELLOR
620 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUSon
621 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVSom
622#endif
623#ifdef UV_VIS4
624 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_LapU
625 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_LapV
626#endif
627 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFe
628 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFx
629 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFe
630 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFx
631 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad
632 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_gzeta
633 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_gzeta2
634#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
635 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_gzetaSA
636#endif
637 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rhs_ubar
638 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rhs_vbar
639 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rhs_zeta
640 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_zeta_new
641 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_zwrk
642#ifdef WET_DRY_NOT_YET
643!^ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_wetdry
644#endif
645
646#include "set_bounds.h"
647!
648 ptsk=3-kstp
649 corrector_2d_step=.not.predictor_2d_step(ng)
650#ifdef DEBUG
651 WRITE (21,20) iic(ng), corrector_2d_step, &
652 & kstp, krhs, knew, ptsk
653 20 FORMAT (' iic = ',i5.5,' corrector = ',l1,' kstp = ',i1, &
654 & ' krhs = ',i1,' knew = ',i1,' ptsk = ',i1)
655#endif
656!
657!-----------------------------------------------------------------------
658! Initialize adjoint private variables.
659!-----------------------------------------------------------------------
660!
661 ad_cff=inival
662 ad_cff1=inival
663 ad_cff2=inival
664 ad_cff3=inival
665 ad_cff4=inival
666 ad_fac=inival
667 ad_fac1=inival
668 DO j=jmins,jmaxs
669 DO i=imins,imaxs
670 ad_dgrad(i,j)=inival
671 ad_dnew(i,j)=inival
672 ad_drhs(i,j)=inival
673 ad_drhs_p(i,j)=inival
674 ad_dstp(i,j)=inival
675 ad_duon(i,j)=inival
676 ad_dvom(i,j)=inival
677#ifdef WEC_MELLOR
678 ad_duson(i,j)=inival
679 ad_dvsom(i,j)=inival
680#endif
681#ifdef UV_VIS4
682 ad_lapu(i,j)=inival
683 ad_lapv(i,j)=inival
684#endif
685 ad_ufe(i,j)=inival
686 ad_ufx(i,j)=inival
687 ad_vfe(i,j)=inival
688 ad_vfx(i,j)=inival
689 ad_grad(i,j)=inival
690 ad_gzeta(i,j)=inival
691 ad_gzeta2(i,j)=inival
692#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
693 ad_gzetasa(i,j)=inival
694#endif
695 ad_rhs_ubar(i,j)=inival
696 ad_rhs_vbar(i,j)=inival
697 ad_rhs_zeta(i,j)=inival
698 ad_zeta_new(i,j)=inival
699 ad_zwrk(i,j)=inival
700 ad_duon(i,j)=inival
701 ad_dvom(i,j)=inival
702
703#ifdef INITIALIZE_AUTOMATIC
704 dgrad(i,j)=inival
705 dnew(i,j)=inival
706 drhs(i,j)=inival
707 drhs_p(i,j)=inival
708 dstp(i,j)=inival
709 duon(i,j)=inival
710 dvom(i,j)=inival
711# ifdef WEC_MELLOR
712 duson(i,j)=inival
713 dvsom(i,j)=inival
714# endif
715# ifdef UV_VIS4
716 lapu(i,j)=inival
717 lapv(i,j)=inival
718 ufe(i,j)=inival
719 ufx(i,j)=inival
720 vfe(i,j)=inival
721 vfx(i,j)=inival
722# endif
723 grad(i,j)=inival
724 gzeta(i,j)=inival
725 gzeta2(i,j)=inival
726# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
727 gzetasa(i,j)=inival
728# endif
729 rhs_ubar(i,j)=inival
730 rhs_vbar(i,j)=inival
731 rhs_zeta(i,j)=inival
732 zeta_new(i,j)=inival
733 zwrk(i,j)=inival
734#endif
735 END DO
736 END DO
737!
738!-----------------------------------------------------------------------
739! Compute BASIC STATE total depth (m) arrays and vertically
740! integerated mass fluxes.
741!-----------------------------------------------------------------------
742!
743#ifdef DISTRIBUTE
744
745! In distributed-memory, the I- and J-ranges are different and a
746! special exchange is done to avoid having three ghost points for
747! high order numerical stencils. Notice that a private array is
748! passed below to the exchange routine. It also applies periodic
749! boundary conditions, if appropriate and no partitions in I- or
750! J-directions.
751!
752 DO j=jstrv-2,jendp2
753 DO i=istru-2,iendp2
754 dnew(i,j)=zeta(i,j,knew)+h(i,j)
755 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
756 dstp(i,j)=zeta(i,j,kstp)+h(i,j)
757 END DO
758 END DO
759 DO j=jstrv-2,jendp2
760 DO i=istru-1,iendp2
761 cff=0.5_r8*on_u(i,j)
762 cff1=cff*(drhs(i,j)+drhs(i-1,j))
763 duon(i,j)=ubar(i,j,krhs)*cff1
764# ifdef WEC_MELLOR
765 duson(i,j)=ubar_stokes(i,j)*cff1
766 duon(i,j)=duon(i,j)+duson(i,j)
767# endif
768 END DO
769 END DO
770 DO j=jstrv-1,jendp2
771 DO i=istru-2,iendp2
772 cff=0.5_r8*om_v(i,j)
773 cff1=cff*(drhs(i,j)+drhs(i,j-1))
774 dvom(i,j)=vbar(i,j,krhs)*cff1
775# ifdef WEC_MELLOR
776 dvsom(i,j)=vbar_stokes(i,j)*cff1
777 dvom(i,j)=dvom(i,j)+dvsom(i,j)
778# endif
779 END DO
780 END DO
781 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
782 CALL exchange_u2d_tile (ng, tile, &
783 & imins, imaxs, jmins, jmaxs, &
784 & duon)
785 CALL exchange_v2d_tile (ng, tile, &
786 & imins, imaxs, jmins, jmaxs, &
787 & dvom)
788 END IF
789 CALL mp_exchange2d (ng, tile, iadm, 2, &
790 & imins, imaxs, jmins, jmaxs, &
791 & nghostpoints, &
792 & ewperiodic(ng), nsperiodic(ng), &
793 & duon, dvom)
794
795#else
796
797 DO j=jstrvm2-1,jendp2
798 DO i=istrum2-1,iendp2
799 dnew(i,j)=zeta(i,j,knew)+h(i,j)
800 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
801 dstp(i,j)=zeta(i,j,kstp)+h(i,j)
802 END DO
803 END DO
804 DO j=jstrvm2-1,jendp2
805 DO i=istrum2,iendp2
806 cff=0.5_r8*on_u(i,j)
807 cff1=cff*(drhs(i,j)+drhs(i-1,j))
808 duon(i,j)=ubar(i,j,krhs)*cff1
809# ifdef WEC_MELLOR
810 duson(i,j)=ubar_stokes(i,j)*cff1
811 duon(i,j)=duon(i,j)+duson(i,j)
812# endif
813 END DO
814 END DO
815 DO j=jstrvm2,jendp2
816 DO i=istrum2-1,iendp2
817 cff=0.5_r8*om_v(i,j)
818 cff1=cff*(drhs(i,j)+drhs(i,j-1))
819 dvom(i,j)=vbar(i,j,krhs)*cff1
820# ifdef WEC_MELLOR
821 dvsom(i,j)=vbar_stokes(i,j)*cff1
822 dvom(i,j)=dvom(i,j)+dvsom(i,j)
823# endif
824 END DO
825 END DO
826#endif
827!
828! Compute integral mass flux across open boundaries and adjust
829! for volume conservation. Compute BASIC STATE value.
830! This must be computed here instead of below.
831!
832 IF (any(ad_volcons(:,ng))) THEN
833 CALL obc_flux_tile (ng, tile, &
834 & lbi, ubi, lbj, ubj, &
835 & imins, imaxs, jmins, jmaxs, &
836 & knew, &
837# ifdef MASKING
838 & umask, vmask, &
839# endif
840 & h, om_v, on_u, &
841 & ubar, vbar, zeta)
842!
843! Set vertically integrated mass fluxes DUon and DVom along the open
844! boundaries in such a way that the integral volume is conserved.
845!
846 CALL set_duv_bc_tile (ng, tile, &
847 & lbi, ubi, lbj, ubj, &
848 & imins, imaxs, jmins, jmaxs, &
849 & krhs, &
850# ifdef MASKING
851 & umask, vmask, &
852# endif
853 & om_v, on_u, &
854 & ubar, vbar, &
855 & drhs, duon, dvom)
856 END IF
857#if defined UV_VIS2 || defined UV_VIS4
858!
859! Compute BASIC state depths at PSI-points for viscosity.
860!
861# ifdef UV_VIS4
862 DO j=jstrm1,jendp2
863 DO i=istrm1,iendp2
864# else
865 DO j=jstr,jend+1
866 DO i=istr,iend+1
867# endif
868 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
869 & drhs(i,j-1)+drhs(i-1,j-1))
870 END DO
871 END DO
872#endif
873!!
874!! Since the BASIC STATE is not recomputed, set right-hand-side
875!! terms.
876!!
877!! DO j=Jstr,Jend
878!! DO i=IstrU,Iend
879!! rhs_ubar(i,j)=rubar(i,j,1)
880!! END DO
881!! END DO
882!! DO j=JstrV,Jend
883!! DO i=Istr,Iend
884!! rhs_vbar(i,j)=rvbar(i,j,1)
885!! END DO
886!! END DO
887!
888! Initialize BASIC STATE right-hand-side terms.
889!
890 DO j=jstr,jend
891 DO i=istr,iend
892 rhs_ubar(i,j)=0.0_r8
893 rhs_vbar(i,j)=0.0_r8
894 END DO
895 END DO
896!
897! Do not perform the actual time stepping during the auxiliary
898! (nfast(ng)+1) time step.
899!
900 step_loop : IF (iif(ng).le.nfast(ng)) THEN
901!
902!-----------------------------------------------------------------------
903! Exchange boundary information.
904!-----------------------------------------------------------------------
905!
906#ifdef DISTRIBUTE
907!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
908!^ & LBi, UBi, LBj, UBj, &
909!^ & NghostPoints, &
910!^ & EWperiodic(ng), NSperiodic(ng), &
911!^ & tl_ubar(:,:,knew), &
912!^ & tl_vbar(:,:,knew))
913!^
914 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
915 & lbi, ubi, lbj, ubj, &
916 & nghostpoints, &
917 & ewperiodic(ng), nsperiodic(ng), &
918 & ad_ubar(:,:,knew), &
919 & ad_vbar(:,:,knew))
920!
921#endif
922
923 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
924!^ CALL exchange_v2d_tile (ng, tile, &
925!^ & LBi, UBi, LBj, UBj, &
926!^ & tl_vbar(:,:,knew))
927!^
928 CALL ad_exchange_v2d_tile (ng, tile, &
929 & lbi, ubi, lbj, ubj, &
930 & ad_vbar(:,:,knew))
931!^ CALL exchange_u2d_tile (ng, tile, &
932!^ & LBi, UBi, LBj, UBj, &
933!^ & tl_ubar(:,:,knew))
934!^
935 CALL ad_exchange_u2d_tile (ng, tile, &
936 & lbi, ubi, lbj, ubj, &
937 & ad_ubar(:,:,knew))
938 END IF
939!
940!-----------------------------------------------------------------------
941! Apply adjoint momentum transport point sources (like river runoff),
942! if any.
943!-----------------------------------------------------------------------
944!
945 IF (luvsrc(ng)) THEN
946 DO is=1,nsrc(ng)
947 i=sources(ng)%Isrc(is)
948 j=sources(ng)%Jsrc(is)
949 IF (((istrr.le.i).and.(i.le.iendr)).and. &
950 & ((jstrr.le.j).and.(j.le.jendr))) THEN
951 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
952 cff=1.0_r8/(on_u(i,j)* &
953 & 0.5_r8*(zeta(i-1,j,knew)+h(i-1,j)+ &
954 & zeta(i ,j,knew)+h(i ,j)))
955!^ tl_ubar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
956!^ & SOURCES(ng)%Qbar(is)*tl_cff
957!^
958 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
959 & cff*ad_ubar(i,j,knew)
960 ad_cff=ad_cff+ &
961 & sources(ng)%Qbar(is)*ad_ubar(i,j,knew)
962 ad_ubar(i,j,knew)=0.0_r8
963!^ tl_cff=-cff*cff*on_u(i,j)* &
964!^ & 0.5_r8*(tl_zeta(i-1,j,knew)+tl_h(i-1,j)+ &
965!^ & tl_zeta(i ,j,knew)+tl_h(i ,j))
966!^
967 adfac=-cff*cff*on_u(i,j)*0.5_r8*ad_cff
968 ad_h(i-1,j)=ad_h(i-1,j)+adfac
969 ad_h(i ,j)=ad_h(i ,j)+adfac
970 ad_zeta(i-1,j,knew)=ad_zeta(i-1,j,knew)+adfac
971 ad_zeta(i ,j,knew)=ad_zeta(i ,j,knew)+adfac
972 ad_cff=0.0_r8
973 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
974 cff=1.0_r8/(om_v(i,j)* &
975 & 0.5_r8*(zeta(i,j-1,knew)+h(i,j-1)+ &
976 & zeta(i,j ,knew)+h(i,j )))
977!^ tl_vbar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
978!^ & SOURCES(ng)%Qbar(is)*tl_cff
979!^
980 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
981 & cff*ad_vbar(i,j,knew)
982 ad_cff=ad_cff+ &
983 & sources(ng)%Qbar(is)*ad_vbar(i,j,knew)
984 ad_vbar(i,j,knew)=0.0_r8
985!^ tl_cff=-cff*cff*om_v(i,j)* &
986!^ & 0.5_r8*(tl_zeta(i,j-1,knew)+tl_h(i,j-1)+ &
987!^ & tl_zeta(i,j ,knew)+tl_h(i,j ))
988!^
989 adfac=-cff*cff*om_v(i,j)*0.5_r8*ad_cff
990 ad_h(i,j-1)=ad_h(i,j-1)+adfac
991 ad_h(i,j )=ad_h(i,j )+adfac
992 ad_zeta(i,j-1,knew)=ad_zeta(i,j-1,knew)+adfac
993 ad_zeta(i,j ,knew)=ad_zeta(i,j ,knew)+adfac
994 ad_cff=0.0_r8
995 END IF
996 END IF
997 END DO
998 END IF
999!
1000!-----------------------------------------------------------------------
1001! Apply adjoint lateral boundary conditions.
1002!-----------------------------------------------------------------------
1003!
1004! Compute integral mass flux across open boundaries and adjust
1005! for adjoint volume conservation.
1006!
1007 IF (any(ad_volcons(:,ng))) THEN
1008!^ CALL tl_obc_flux_tile (ng, tile, &
1009!^ & LBi, UBi, LBj, UBj, &
1010!^ & IminS, ImaxS, JminS, JmaxS, &
1011!^ & knew, &
1012# ifdef MASKING
1013!^ & umask, vmask, &
1014# endif
1015!^ & h, tl_h, om_v, on_u, &
1016!^ & ubar, vbar, zeta, &
1017!^ & tl_ubar, tl_vbar, tl_zeta)
1018!^
1019 CALL ad_obc_flux_tile (ng, tile, &
1020 & lbi, ubi, lbj, ubj, &
1021 & imins, imaxs, jmins, jmaxs, &
1022 & knew, &
1023# ifdef MASKING
1024 & umask, vmask, &
1025# endif
1026 & h, ad_h, om_v, on_u, &
1027 & ubar, vbar, zeta, &
1028 & ad_ubar, ad_vbar, ad_zeta)
1029 END IF
1030!
1031! Adjoint lateral boundary conditons.
1032!
1033!^ CALL tl_v2dbc_tile (ng, tile, &
1034!^ & LBi, UBi, LBj, UBj, &
1035!^ & IminS, ImaxS, JminS, JmaxS, &
1036!^ & krhs, kstp, knew, &
1037!^ & ubar, vbar, zeta, &
1038!^ & tl_ubar, tl_vbar, tl_zeta)
1039!^
1040 CALL ad_v2dbc_tile (ng, tile, &
1041 & lbi, ubi, lbj, ubj, &
1042 & imins, imaxs, jmins, jmaxs, &
1043 & krhs, kstp, knew, &
1044 & ubar, vbar, zeta, &
1045 & ad_ubar, ad_vbar, ad_zeta)
1046!^ CALL tl_u2dbc_tile (ng, tile, &
1047!^ & LBi, UBi, LBj, UBj, &
1048!^ & IminS, ImaxS, JminS, JmaxS, &
1049!^ & krhs, kstp, knew, &
1050!^ & ubar, vbar, zeta, &
1051!^ & tl_ubar, tl_vbar, tl_zeta)
1052!^
1053 CALL ad_u2dbc_tile (ng, tile, &
1054 & lbi, ubi, lbj, ubj, &
1055 & imins, imaxs, jmins, jmaxs, &
1056 & krhs, kstp, knew, &
1057 & ubar, vbar, zeta, &
1058 & ad_ubar, ad_vbar, ad_zeta)
1059!
1060! If predictor step, load right-side-term into shared arrays for
1061! future use during the subsequent corrector step.
1062!
1063 IF (predictor_2d_step(ng)) THEN
1064#ifdef DIAGNOSTICS_UV
1065!! DO idiag=1,NDM2d-1
1066!! DO j=Jstr,Jend
1067!! DO i=IstrU,Iend
1068!! DiaRUbar(i,j,krhs,idiag)=DiaU2rhs(i,j,idiag)
1069!! END DO
1070!! END DO
1071!! DO j=JstrV,Jend
1072!! DO i=Istr,Iend
1073!! DiaRVbar(i,j,krhs,idiag)=DiaV2rhs(i,j,idiag)
1074!! END DO
1075!! END DO
1076!! END DO
1077#endif
1078 DO j=jstrv,jend
1079 DO i=istr,iend
1080!^ tl_rvbar(i,j,krhs)=tl_rhs_vbar(i,j)
1081!^
1082 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)+ad_rvbar(i,j,krhs)
1083 ad_rvbar(i,j,krhs)=0.0_r8
1084 END DO
1085 END DO
1086 DO j=jstr,jend
1087 DO i=istru,iend
1088!^ tl_rubar(i,j,krhs)=tl_rhs_ubar(i,j)
1089!^
1090 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)+ad_rubar(i,j,krhs)
1091 ad_rubar(i,j,krhs)=0.0_r8
1092 END DO
1093 END DO
1094 END IF
1095#ifdef DIAGNOSTICS_UV
1096!!
1097!!-----------------------------------------------------------------------
1098!! Time step 2D momentum diagnostic terms.
1099!!-----------------------------------------------------------------------
1100!!
1101# ifdef SOLVE3D
1102!!
1103!! The arrays "DiaU2rhs" and "DiaV2rhs" contain the contributions of
1104!! each of the 2D right-hand-side terms for the momentum equations.
1105!!
1106!! These values are integrated, time-stepped and converted to mass flux
1107!! units (m3 s-1) for coupling with the 3D diagnostic terms.
1108!!
1109!! fac=weight(1,iif(ng),ng)
1110!! IF (FIRST_2D_STEP.and.CORRECTOR_2D_STEP) THEN
1111!! cff1=0.5_r8*dtfast(ng)
1112!! DO idiag=1,NDM2d-1
1113!! DO j=JstrV,Jend
1114!! DO i=Istr,Iend
1115!! DiaV2wrk(i,j,idiag)=DiaV2int(i,j,idiag)* &
1116!! & (pn(i,j)+pn(i,j-1))*fac
1117!! DiaV2int(i,j,idiag)=cff1*DiaV2rhs(i,j,idiag)
1118!! END DO
1119!! END DO
1120!! DO j=Jstr,Jend
1121!! DO i=IstrU,Iend
1122!! DiaU2wrk(i,j,idiag)=DiaU2int(i,j,idiag)* &
1123!! & (pm(i-1,j)+pm(i,j))*fac
1124!! DiaU2int(i,j,idiag)=cff1*DiaU2rhs(i,j,idiag)
1125!! END DO
1126!! END DO
1127!! END DO
1128!! ELSE IF (CORRECTOR_2D_STEP) THEN
1129!! cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
1130!! cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
1131!! cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
1132!! DO idiag=1,NDM2d-1
1133!! DO j=JstrV,Jend
1134!! DO i=Istr,Iend
1135!! DiaV2wrk(i,j,idiag)=DiaV2wrk(i,j,idiag)+ &
1136!! & DiaV2int(i,j,idiag)* &
1137!! & (pn(i,j)+pn(i,j-1))*fac
1138!! DiaV2int(i,j,idiag)=DiaV2int(i,j,idiag)+ &
1139!! & (cff1*DiaV2rhs(i,j,idiag)+ &
1140!! & cff2*DiaRVbar(i,j,kstp,idiag)- &
1141!! & cff3*DiaRVbar(i,j,ptsk,idiag))
1142!! END DO
1143!! END DO
1144!! DO j=Jstr,Jend
1145!! DO i=IstrU,Iend
1146!! DiaU2wrk(i,j,idiag)=DiaU2wrk(i,j,idiag)+ &
1147!! & DiaU2int(i,j,idiag)* &
1148!! & (pm(i-1,j)+pm(i,j))*fac
1149!! DiaU2int(i,j,idiag)=DiaU2int(i,j,idiag)+ &
1150!! & (cff1*DiaU2rhs(i,j,idiag)+ &
1151!! & cff2*DiaRUbar(i,j,kstp,idiag)- &
1152!! & cff3*DiaRUbar(i,j,ptsk,idiag))
1153!! END DO
1154!! END DO
1155!! END DO
1156!! END IF
1157# else
1158!!
1159!! Time-step the diagnostic terms.
1160!!
1161!! IF (FIRST_2D_STEP.and.CORRECTOR_2D_STEP) THEN
1162!! cff1=0.5_r8*dtfast(ng)
1163!! DO j=JstrV,Jend
1164!! DO i=Istr,Iend
1165!! DiaV2wrk(i,j,M2rate)=vbar(i,j,knew)-vbar(i,j,kstp)* &
1166!! & (Dstp(i,j)+Dstp(i,j-1))*fac
1167!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
1168!! END DO
1169!! END DO
1170!! DO j=Jstr,Jend
1171!! DO i=IstrU,Iend
1172!! DiaU2wrk(i,j,M2rate)=ubar(i,j,knew)-ubar(i,j,kstp)* &
1173!! & (Dstp(i,j)+Dstp(i-1,j))*fac
1174!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
1175!! END DO
1176!! END DO
1177!! DO idiag=1,NDM2d-1
1178!! DO j=JstrV,Jend
1179!! DO i=Istr,Iend
1180!! cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1181!! DiaV2wrk(i,j,idiag)=cff*cff1*DiaV2rhs(i,j,idiag)*fac
1182!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
1183!! END DO
1184!! END DO
1185!! DO j=Jstr,Jend
1186!! DO i=IstrU,Iend
1187!! cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1188!! DiaU2wrk(i,j,idiag)=cff*cff1*DiaU2rhs(i,j,idiag)*fac
1189!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
1190!! END DO
1191!! END DO
1192!! END DO
1193!! ELSE IF (CORRECTOR_2D_STEP) THEN
1194!! cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
1195!! cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
1196!! cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
1197!! DO j=JstrV,Jend
1198!! DO i=Istr,Iend
1199!! DiaV2wrk(i,j,M2rate)=vbar(i,j,knew)- &
1200!! & vbar(i,j,kstp)* &
1201!! & (Dstp(i,j)+Dstp(i,j-1))*fac
1202!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
1203!! END DO
1204!! END DO
1205!! DO j=Jstr,Jend
1206!! DO i=IstrU,Iend
1207!! DiaU2wrk(i,j,M2rate)=ubar(i,j,knew)- &
1208!! & ubar(i,j,kstp)* &
1209!! & (Dstp(i,j)+Dstp(i-1,j))*fac
1210!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
1211!! END DO
1212!! END DO
1213!! DO idiag=1,NDM2d-1
1214!! DO j=JstrV,Jend
1215!! DO i=Istr,Iend
1216!! cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1217!! DiaV2wrk(i,j,idiag)=cff*(cff1*DiaV2rhs(i,j,idiag)+ &
1218!! & cff2*DiaRVbar(i,j,kstp,idiag)- &
1219!! & cff3*DiaRVbar(i,j,ptsk,idiag))*&
1220!! & fac
1221!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
1222!! END DO
1223!! END DO
1224!! DO j=Jstr,Jend
1225!! DO i=IstrU,Iend
1226!! cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1227!! DiaU2wrk(i,j,idiag)=cff*(cff1*DiaU2rhs(i,j,idiag)+ &
1228!! & cff2*DiaRUbar(i,j,kstp,idiag)- &
1229!! & cff3*DiaRUbar(i,j,ptsk,idiag))*&
1230!! & fac
1231!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
1232!! END DO
1233!! END DO
1234!! END DO
1235!! END IF
1236# endif
1237#endif
1238!
1239!=======================================================================
1240! Time step adjoint 2D momentum equations.
1241!=======================================================================
1242
1243#ifndef SOLVE3D
1244!
1245! Save 2D momentum adjoint solution for IO purposes.
1246!
1247 DO j=jstrr,jendr
1248 DO i=istr,iendr
1249 ad_ubar_sol(i,j)=ad_ubar(i,j,knew)
1250 END DO
1251 IF (j.ge.jstr) THEN
1252 DO i=istrr,iendr
1253 ad_vbar_sol(i,j)=ad_vbar(i,j,knew)
1254 END DO
1255 END IF
1256 END DO
1257#endif
1258!
1259! During the first time-step, the predictor step is Forward-Euler
1260! and the corrector step is Backward-Euler. Otherwise, the predictor
1261! step is Leap-frog and the corrector step is Adams-Moulton.
1262#ifdef WET_DRY_NOT_YET
1263! HGA: This option is not fully adjointed yet. We need to resolve
1264! the issued time-dependent wet/dry mask arrays.
1265#endif
1266!
1267 IF (first_2d_step) THEN
1268 cff1=0.5_r8*dtfast(ng)
1269#ifdef WET_DRY_NOT_YET
1270 cff2=1.0_r8/cff1
1271#endif
1272 DO j=jstrv,jend
1273 DO i=istr,iend
1274 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1275 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
1276#ifdef WET_DRY_NOT_YET
1277 fac1=cff2/cff
1278!^ tl_rhs_vbar(i,j)=(tl_vbar(i,j,knew)* &
1279!^ & (Dnew(i,j)+Dnew(i,j-1))+ &
1280!^ & vbar(i,j,knew)* &
1281!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))- &
1282!^ & tl_vbar(i,j,kstp)* &
1283!^ & (Dstp(i,j)+Dstp(i,j-1))- &
1284!^ & vbar(i,j,kstp)* &
1285!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1)))*fac1
1286!^
1287 adfac=fac1*ad_rhs_vbar(i,j)
1288 adfac1=adfac*vbar(i,j,knew)
1289 adfac2=adfac*vbar(i,j,kstp)
1290 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1291 & (dnew(i,j)+dnew(i,j-1))*adfac
1292 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)- &
1293 & (dstp(i,j)+dstp(i,j-1))*adfac
1294 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1295 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1296 ad_dstp(i,j-1)=ad_dstp(i,j-1)-adfac2
1297 ad_dstp(i,j )=ad_dstp(i,j )-adfac2
1298 ad_rhs_vbar(i,j)=0.0_r8
1299!^
1300!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1301!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1302!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1303!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1304!^
1305!^ HGA: ADM code needed here for the above NLM code.
1306!^
1307#endif
1308#ifdef MASKING
1309!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1310!^
1311 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1312#endif
1313!^ tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
1314!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1315!^ & vbar(i,j,kstp)* &
1316!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))+ &
1317!^ & cff*cff1*tl_rhs_vbar(i,j))*fac+ &
1318!^ & (vbar(i,j,kstp)* &
1319!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1320!^ & cff*cff1*rhs_vbar(i,j))*tl_fac
1321!^
1322 adfac=fac*ad_vbar(i,j,knew)
1323 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1324 adfac2=adfac*cff*cff1
1325 adfac3=adfac*vbar(i,j,kstp)
1326 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+adfac1
1327 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)+adfac2
1328 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1329 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1330 ad_fac=ad_fac+ &
1331 & (vbar(i,j,kstp)*(dstp(i,j)+dstp(i,j-1))+ &
1332 & cff*cff1*rhs_vbar(i,j))*ad_vbar(i,j,knew)
1333 ad_vbar(i,j,knew)=0.0_r8
1334!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i,j-1))
1335!^
1336 adfac=-fac*fac*ad_fac
1337 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1338 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1339 ad_fac=0.0_r8
1340 END DO
1341 END DO
1342 DO j=jstr,jend
1343 DO i=istru,iend
1344 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1345 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
1346#ifdef WET_DRY_NOT_YET
1347 fac1=cff2/cff
1348!^ tl_rhs_ubar(i,j)=(tl_ubar(i,j,knew)* &
1349!^ & (Dnew(i,j)+Dnew(i-1,j))+ &
1350!^ & ubar(i,j,knew)* &
1351!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))- &
1352!^ & tl_ubar(i,j,kstp)* &
1353!^ & (Dstp(i,j)+Dstp(i-1,j))- &
1354!^ & ubar(i,j,kstp)* &
1355!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j)))*fac1
1356!^
1357 adfac=fac1*ad_rhs_ubar(i,j)
1358 adfac1=adfac*ubar(i,j,knew)
1359 adfac2=adfac*ubar(i,j,kstp)
1360 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1361 & (dnew(i,j)+dnew(i-1,j))*adfac
1362 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)- &
1363 & (dstp(i,j)+dstp(i-1,j))*adfac
1364 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1365 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1366 ad_dstp(i-1,j)=ad_dstp(i-1,j)-adfac2
1367 ad_dstp(i ,j)=ad_dstp(i ,j)-adfac2
1368 ad_rhs_ubar(i,j)=0.0_r8
1369!^
1370!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1371!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1372!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1373!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1374!^
1375!^ HGA: ADM code needed here for the above NLM code.
1376!^
1377#endif
1378#ifdef MASKING
1379!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1380!^
1381 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1382#endif
1383!^ tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
1384!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1385!^ & ubar(i,j,kstp)* &
1386!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))+ &
1387!^ & cff*cff1*tl_rhs_ubar(i,j))*fac+ &
1388!^ & (ubar(i,j,kstp)* &
1389!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1390!^ & cff*cff1*rhs_ubar(i,j))*tl_fac
1391!^
1392 adfac=fac*ad_ubar(i,j,knew)
1393 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
1394 adfac2=adfac*cff*cff1
1395 adfac3=adfac*ubar(i,j,kstp)
1396 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+adfac1
1397 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)+adfac2
1398 ad_dstp(i-1,j)=ad_dstp(i-1,j)+adfac3
1399 ad_dstp(i ,j)=ad_dstp(i ,j)+adfac3
1400 ad_fac=ad_fac+ &
1401 & (ubar(i,j,kstp)*(dstp(i,j)+dstp(i-1,j))+ &
1402 & cff*cff1*rhs_ubar(i,j))*ad_ubar(i,j,knew)
1403 ad_ubar(i,j,knew)=0.0_r8
1404!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i-1,j))
1405!^
1406 adfac=-fac*fac*ad_fac
1407 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1408 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1409 ad_fac=0.0_r8
1410 END DO
1411 END DO
1412 ELSE IF (predictor_2d_step(ng)) THEN
1413 cff1=dtfast(ng)
1414#ifdef WET_DRY_NOT_YET
1415 cff2=1.0_r8/cff1
1416#endif
1417 DO j=jstrv,jend
1418 DO i=istr,iend
1419 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1420 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
1421#ifdef WET_DRY_NOT_YET
1422 fac1=cff2/cff
1423!^ tl_rhs_vbar(i,j)=(tl_vbar(i,j,knew)* &
1424!^ & (Dnew(i,j)+Dnew(i,j-1))+ &
1425!^ & vbar(i,j,knew)* &
1426!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))- &
1427!^ & tl_vbar(i,j,kstp)* &
1428!^ & (Dstp(i,j)+Dstp(i,j-1))- &
1429!^ & vbar(i,j,kstp)* &
1430!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1)))*fac1
1431!^
1432 adfac=fac1*ad_rhs_vbar(i,j)
1433 adfac1=adfac*vbar(i,j,knew)
1434 adfac2=adfac*vbar(i,j,kstp)
1435 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1436 & (dnew(i,j)+dnew(i,j-1))*adfac
1437 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)- &
1438 & (dstp(i,j)+dstp(i,j-1))*adfac
1439 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1440 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1441 ad_dstp(i,j-1)=ad_dstp(i,j-1)-adfac2
1442 ad_dstp(i,j )=ad_dstp(i,j )-adfac2
1443 ad_rhs_vbar(i,j)=0.0_r8
1444!^
1445!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1446!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1447!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1448!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1449!^
1450!^ HGA: ADM code needed here for the above NLM code.
1451!^
1452#endif
1453#ifdef MASKING
1454!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1455!^
1456 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1457#endif
1458!^ tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
1459!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1460!^ & vbar(i,j,kstp)* &
1461!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))+ &
1462!^ & cff*cff1*tl_rhs_vbar(i,j))*fac+ &
1463!^ & (vbar(i,j,kstp)* &
1464!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1465!^ & cff*cff1*rhs_vbar(i,j))*tl_fac
1466!^
1467 adfac=fac*ad_vbar(i,j,knew)
1468 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1469 adfac2=adfac*cff*cff1
1470 adfac3=adfac*vbar(i,j,kstp)
1471 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+adfac1
1472 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)+adfac2
1473 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1474 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1475 ad_fac=ad_fac+ &
1476 & (vbar(i,j,kstp)*(dstp(i,j)+dstp(i,j-1))+ &
1477 & cff*cff1*rhs_vbar(i,j))*ad_vbar(i,j,knew)
1478 ad_vbar(i,j,knew)=0.0_r8
1479!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i,j-1))
1480!^
1481 adfac=-fac*fac*ad_fac
1482 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1483 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1484 ad_fac=0.0_r8
1485 END DO
1486 END DO
1487 DO j=jstr,jend
1488 DO i=istru,iend
1489 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1490 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
1491#ifdef WET_DRY_NOT_YET
1492 fac1=cff2/cff
1493!^ tl_rhs_ubar(i,j)=(tl_ubar(i,j,knew)* &
1494!^ & (Dnew(i,j)+Dnew(i-1,j))+ &
1495!^ & ubar(i,j,knew)* &
1496!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))- &
1497!^ & tl_ubar(i,j,kstp)* &
1498!^ & (Dstp(i,j)+Dstp(i-1,j))- &
1499!^ & ubar(i,j,kstp)* &
1500!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j)))*fac1
1501!^
1502 adfac=fac1*ad_rhs_ubar(i,j)
1503 adfac1=adfac*ubar(i,j,knew)
1504 adfac2=adfac*ubar(i,j,kstp)
1505 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1506 & (dnew(i,j)+dnew(i-1,j))*adfac
1507 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)- &
1508 (dstp(i,j)+dstp(i-1,j))*adfac
1509 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1510 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1511 ad_dstp(i-1,j)=ad_dstp(i-1,j)-adfac2
1512 ad_dstp(i ,j)=ad_dstp(i ,j)-adfac2
1513 ad_rhs_ubar(i,j)=0.0_r8
1514!^
1515!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1516!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1517!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1518!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1519!^
1520!^ HGA: ADM code needed here for the above NLM code.
1521!^
1522#endif
1523#ifdef MASKING
1524!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1525!^
1526 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1527#endif
1528!^ tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
1529!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1530!^ & ubar(i,j,kstp)* &
1531!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))+ &
1532!^ & cff*cff1*tl_rhs_ubar(i,j))*fac+ &
1533!^ & (ubar(i,j,kstp)* &
1534!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1535!^ & cff*cff1*rhs_ubar(i,j))*tl_fac
1536!^
1537 adfac=fac*ad_ubar(i,j,knew)
1538 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
1539 adfac2=adfac*cff*cff1
1540 adfac3=adfac*ubar(i,j,kstp)
1541 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+adfac1
1542 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)+adfac2
1543 ad_dstp(i-1,j)=ad_dstp(i-1,j)+adfac3
1544 ad_dstp(i ,j)=ad_dstp(i ,j)+adfac3
1545 ad_fac=ad_fac+ &
1546 & (ubar(i,j,kstp)*(dstp(i,j)+dstp(i-1,j))+ &
1547 & cff*cff1*rhs_ubar(i,j))*ad_ubar(i,j,knew)
1548 ad_ubar(i,j,knew)=0.0_r8
1549!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i-1,j))
1550!^
1551 adfac=-fac*fac*ad_fac
1552 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1553 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1554 ad_fac=0.0_r8
1555 END DO
1556 END DO
1557 ELSE IF (corrector_2d_step) THEN
1558 cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
1559 cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
1560 cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
1561#ifdef WET_DRY_NOT_YET
1562 cff4=1.0_r8/cff1
1563#endif
1564 DO j=jstrv,jend
1565 DO i=istr,iend
1566 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1567 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
1568#ifdef WET_DRY_NOT_YET
1569 fac1=1.0_r8/cff
1570!^ tl_rhs_vbar(i,j)=((tl_vbar(i,j,knew)* &
1571!^ & (Dnew(i,j)+Dnew(i,j-1))+ &
1572!^ & vbar(i,j,knew)* &
1573!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))- &
1574!^ & tl_vbar(i,j,kstp)* &
1575!^ & (Dstp(i,j)+Dstp(i,j-1))- &
1576!^ & vbar(i,j,kstp)* &
1577!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1)))*fac1- &
1578!^ & cff2*tl_rvbar(i,j,kstp)+ &
1579!^ & cff3*tl_rvbar(i,j,ptsk))*cff4
1580!^
1581 adfac=cff4*ad_rhs_vbar(i,j)
1582 adfac1=adfac*fac1*vbar(i,j,knew)
1583 adfac2=adfac*fac1*vbar(i,j,kstp)
1584 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1585 & (dnew(i,j)+dnew(i,j-1))*adfac
1586 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)- &
1587 & (dstp(i,j)+dstp(i,j-1))*adfac
1588 ad_rvbar(i,j,kstp)=ad_rvbar(i,j,kstp)-cff2*adfac
1589 ad_rvbar(i,j,ptsk)=ad_rvbar(i,j,ptsk)+cff3*adfac
1590 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1591 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1592 ad_dstp(i,j-1)=ad_dstp(i,j-1)-adfac2
1593 ad_dstp(i,j )=ad_dstp(i,j )-adfac2
1594 ad_rhs_vbar(i,j)=0.0_r8
1595!^
1596!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1597!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1598!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1599!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1600!^
1601!^ HGA: ADM code needed here for the above NLM code.
1602!^
1603#endif
1604#ifdef MASKING
1605!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1606!^
1607 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1608#endif
1609!^ tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
1610!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1611!^ & vbar(i,j,kstp)* &
1612!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))+ &
1613!^ & cff*(cff1*tl_rhs_vbar(i,j)+ &
1614!^ & cff2*tl_rvbar(i,j,kstp)- &
1615!^ & cff3*tl_rvbar(i,j,ptsk)))*fac+ &
1616!^ & (vbar(i,j,kstp)* &
1617!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1618!^ & cff*(cff1*rhs_vbar(i,j)+ &
1619!^ & cff2*rvbar(i,j,kstp)- &
1620!^ & cff3*rvbar(i,j,ptsk)))*tl_fac
1621!^
1622 adfac=fac*ad_vbar(i,j,knew)
1623 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1624 adfac2=adfac*cff
1625 adfac3=adfac*vbar(i,j,kstp)
1626 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+adfac1
1627 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)+cff1*adfac2
1628 ad_rvbar(i,j,kstp)=ad_rvbar(i,j,kstp)+cff2*adfac2
1629 ad_rvbar(i,j,ptsk)=-cff3*adfac2
1630 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1631 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1632 ad_fac=ad_fac+ &
1633 & (vbar(i,j,kstp)*(dstp(i,j)+dstp(i,j-1))+ &
1634 & cff*(cff1*rhs_vbar(i,j)+ &
1635 & cff2*rvbar(i,j,kstp)- &
1636 & cff3*rvbar(i,j,ptsk)))*ad_vbar(i,j,knew)
1637 ad_vbar(i,j,knew)=0.0_r8
1638!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i,j-1))
1639!^
1640 adfac=-fac*fac*ad_fac
1641 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1642 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1643 ad_fac=0.0_r8
1644 END DO
1645 END DO
1646 DO j=jstr,jend
1647 DO i=istru,iend
1648 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1649 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
1650#ifdef WET_DRY_NOT_YET
1651 fac1=1.0_r8/cff
1652!^ tl_rhs_ubar(i,j)=((tl_ubar(i,j,knew)* &
1653!^ & (Dnew(i,j)+Dnew(i-1,j))+ &
1654!^ & ubar(i,j,knew)* &
1655!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))- &
1656!^ & tl_ubar(i,j,kstp)* &
1657!^ & (Dstp(i,j)+Dstp(i-1,j))- &
1658!^ & ubar(i,j,kstp)* &
1659!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j)))*fac1- &
1660!^ & cff2*tl_rubar(i,j,kstp)+ &
1661!^ & cff3*tl_rubar(i,j,ptsk))*cff4
1662!^
1663 adfac=cff4*ad_rhs_ubar(i,j)
1664 adfac1=adfac*fac1*ubar(i,j,knew)
1665 adfac2=adfac*fac1*ubar(i,j,kstp)
1666 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1667 & (dnew(i,j)+dnew(i-1,j))*adfac
1668 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)- &
1669 & (dstp(i,j)+dstp(i-1,j))*adfac
1670 ad_rubar(i,j,kstp)=ad_rubar(i,j,kstp)-cff2*adfac
1671 ad_rubar(i,j,ptsk)=ad_rubar(i,j,ptsk)+cff3*adfac
1672 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1673 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1674 ad_dstp(i-1,j)=ad_dstp(i-1,j)-adfac2
1675 ad_dstp(i ,j)=ad_dstp(i ,j)-adfac2
1676 ad_rhs_ubar(i,j)=0.0_r8
1677!^
1678!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1679!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1680!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1681!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1682!^
1683!^ HGA: ADM code needed here for the above NLM code.
1684!^
1685#endif
1686#ifdef MASKING
1687!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1688!^
1689 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1690#endif
1691!^ tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
1692!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1693!^ & ubar(i,j,kstp)* &
1694!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))+ &
1695!^ & cff*(cff1*tl_rhs_ubar(i,j)+ &
1696!^ & cff2*tl_rubar(i,j,kstp)- &
1697!^ & cff3*tl_rubar(i,j,ptsk)))*fac+ &
1698!^ & (ubar(i,j,kstp)* &
1699!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1700!^ & cff*(cff1*rhs_ubar(i,j)+ &
1701!^ & cff2*rubar(i,j,kstp)- &
1702!^ & cff3*rubar(i,j,ptsk)))*tl_fac
1703!^
1704 adfac=fac*ad_ubar(i,j,knew)
1705 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
1706 adfac2=adfac*cff
1707 adfac3=adfac*ubar(i,j,kstp)
1708 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+adfac1
1709 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)+cff1*adfac2
1710 ad_rubar(i,j,kstp)=ad_rubar(i,j,kstp)+cff2*adfac2
1711 ad_rubar(i,j,ptsk)=-cff3*adfac2
1712 ad_dstp(i-1,j)=ad_dstp(i-1,j)+adfac3
1713 ad_dstp(i ,j)=ad_dstp(i ,j)+adfac3
1714 ad_fac=ad_fac+ &
1715 & (ubar(i,j,kstp)*(dstp(i,j)+dstp(i-1,j))+ &
1716 & cff*(cff1*rhs_ubar(i,j)+ &
1717 & cff2*rubar(i,j,kstp)- &
1718 & cff3*rubar(i,j,ptsk)))*ad_ubar(i,j,knew)
1719 ad_ubar(i,j,knew)=0.0_r8
1720!^ tl_fac=-fac*fac*(tl_Dnew(i,j)+tl_Dnew(i-1,j))
1721!^
1722 adfac=-fac*fac*ad_fac
1723 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1724 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1725 ad_fac=0.0_r8
1726 END DO
1727 END DO
1728 END IF
1729!
1730! Compute adjoint total water column depth.
1731!
1732 DO j=jstrv-1,jend
1733 DO i=istru-1,iend
1734!^ tl_Dstp(i,j)=tl_zeta(i,j,kstp)+tl_h(i,j)
1735!^
1736 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_dstp(i,j)
1737 ad_h(i,j)=ad_h(i,j)+ad_dstp(i,j)
1738 ad_dstp(i,j)=0.0_r8
1739 END DO
1740 END DO
1741!
1742!=======================================================================
1743! Compute right-hand-side for the 2D momentum equations.
1744!=======================================================================
1745
1746#ifdef SOLVE3D
1747!
1748!-----------------------------------------------------------------------
1749! Adjoint Coupling between 2D and 3D equations.
1750!-----------------------------------------------------------------------
1751!
1752! Before the predictor step of the first barotropic time-step,
1753! arrays "rufrc" and "rvfrc" contain the vertical integrals of
1754! the 3D right-hand-side terms for momentum equations (including
1755! surface and bottom stresses, if so prescribed).
1756!
1757! Convert them into forcing terms by subtracting the fast time
1758! "rhs_ubar" and "rhs_vbar" from them; Also, immediately apply
1759! these forcing terms "rhs_ubar" and "rhs_vbar".
1760!
1761! From now on, these newly computed forcing terms will remain
1762! constant during the fast time stepping and will added to
1763! "rhs_ubar" and "rhs_vbar" during all subsequent time steps.
1764!
1765 IF (first_2d_step.and.predictor_2d_step(ng)) THEN
1766 IF (iic(ng).eq.ntfirst(ng)) THEN
1767 DO j=jstrv,jend
1768 DO i=istr,iend
1769# ifdef DIAGNOSTICS_UV
1770!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
1771!! DiaV2rhs(i,j,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
1772!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
1773!! DiaV2rhs(i,j,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
1774!! DO idiag=1,M2pgrd
1775!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
1776!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
1777!! & DiaRVfrc(i,j,3,idiag)
1778!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
1779!! & DiaV2rhs(i,j,idiag)
1780!! END DO
1781# endif
1782!^ tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
1783!^
1784 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_rv(i,j,0,nstp)
1785 ad_rv(i,j,0,nstp)=0.0_r8
1786!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_rvfrc(i,j)
1787!^
1788 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_rhs_vbar(i,j)
1789!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
1790!^
1791 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)-ad_rvfrc(i,j)
1792 END DO
1793 END DO
1794 DO j=jstr,jend
1795 DO i=istru,iend
1796# ifdef DIAGNOSTICS_UV
1797!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
1798!! DiaU2rhs(i,j,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
1799!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
1800!! DiaU2rhs(i,j,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
1801!! DO idiag=1,M2pgrd
1802!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
1803!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
1804!! & DiaRUfrc(i,j,3,idiag)
1805!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
1806!! & DiaU2rhs(i,j,idiag)
1807!! END DO
1808# endif
1809!^ tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
1810!^
1811 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_ru(i,j,0,nstp)
1812 ad_ru(i,j,0,nstp)=0.0_r8
1813!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_rufrc(i,j)
1814!^
1815 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_rhs_ubar(i,j)
1816!^ tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
1817!^
1818 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)-ad_rufrc(i,j)
1819 END DO
1820 END DO
1821 ELSE IF (iic(ng).eq.(ntfirst(ng)+1)) THEN
1822 DO j=jstrv,jend
1823 DO i=istr,iend
1824# ifdef DIAGNOSTICS_UV
1825!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
1826!! DiaV2rhs(i,j,M2bstr)=1.5_r8*DiaRVfrc(i,j,3,M2bstr)- &
1827!! & 0.5_r8*DiaRVfrc(i,j,nnew,M2bstr)
1828!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
1829!! DiaV2rhs(i,j,M2sstr)=1.5_r8*DiaRVfrc(i,j,3,M2sstr)- &
1830!! & 0.5_r8*DiaRVfrc(i,j,nnew,M2sstr)
1831!! DO idiag=1,M2pgrd
1832!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
1833!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
1834!! & 1.5_r8*DiaRVfrc(i,j,3,idiag)- &
1835!! & 0.5_r8*DiaRVfrc(i,j,nnew,idiag)
1836!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
1837!! & DiaV2rhs(i,j,idiag)
1838!! END DO
1839# endif
1840!^ tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
1841!^
1842 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_rv(i,j,0,nstp)
1843 ad_rv(i,j,0,nstp)=0.0_r8
1844!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
1845!^ & 1.5_r8*tl_rvfrc(i,j)- &
1846!^ & 0.5_r8*tl_rv(i,j,0,nnew)
1847!^
1848 ad_rvfrc(i,j)=ad_rvfrc(i,j)+1.5_r8*ad_rhs_vbar(i,j)
1849 ad_rv(i,j,0,nnew)=ad_rv(i,j,0,nnew)- &
1850 & 0.5_r8*ad_rhs_vbar(i,j)
1851!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
1852!^
1853 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)-ad_rvfrc(i,j)
1854 END DO
1855 END DO
1856 DO j=jstr,jend
1857 DO i=istru,iend
1858# ifdef DIAGNOSTICS_UV
1859!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
1860!! DiaU2rhs(i,j,M2bstr)=1.5_r8*DiaRUfrc(i,j,3,M2bstr)- &
1861!! & 0.5_r8*DiaRUfrc(i,j,nnew,M2bstr)
1862!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
1863!! DiaU2rhs(i,j,M2sstr)=1.5_r8*DiaRUfrc(i,j,3,M2sstr)- &
1864!! & 0.5_r8*DiaRUfrc(i,j,nnew,M2sstr)
1865!! DO idiag=1,M2pgrd
1866!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
1867!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
1868!! & 1.5_r8*DiaRUfrc(i,j,3,idiag)- &
1869!! & 0.5_r8*DiaRUfrc(i,j,nnew,idiag)
1870!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
1871!! & DiaU2rhs(i,j,idiag)
1872!! END DO
1873# endif
1874!^ tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
1875!^
1876 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_ru(i,j,0,nstp)
1877 ad_ru(i,j,0,nstp)=0.0_r8
1878!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
1879!^ & 1.5_r8*tl_rufrc(i,j)- &
1880!^ & 0.5_r8*tl_ru(i,j,0,nnew)
1881!^
1882 ad_rufrc(i,j)=ad_rufrc(i,j)+1.5_r8*ad_rhs_ubar(i,j)
1883 ad_ru(i,j,0,nnew)=ad_ru(i,j,0,nnew)- &
1884 & 0.5_r8*ad_rhs_ubar(i,j)
1885!^ tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
1886!^
1887 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)-ad_rufrc(i,j)
1888 END DO
1889 END DO
1890 ELSE
1891 cff1=23.0_r8/12.0_r8
1892 cff2=16.0_r8/12.0_r8
1893 cff3= 5.0_r8/12.0_r8
1894 DO j=jstrv,jend
1895 DO i=istr,iend
1896# ifdef DIAGNOSTICS_UV
1897!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
1898!! DiaV2rhs(i,j,M2bstr)=cff1*DiaRVfrc(i,j,3,M2bstr)- &
1899!! & cff2*DiaRVfrc(i,j,nnew,M2bstr)+ &
1900!! & cff3*DiaRVfrc(i,j,nstp,M2bstr)
1901!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
1902!! DiaV2rhs(i,j,M2sstr)=cff1*DiaRVfrc(i,j,3,M2sstr)- &
1903!! & cff2*DiaRVfrc(i,j,nnew,M2sstr)+ &
1904!! & cff3*DiaRVfrc(i,j,nstp,M2sstr)
1905!! DO idiag=1,M2pgrd
1906!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
1907!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
1908!! & cff1*DiaRVfrc(i,j,3,idiag)- &
1909!! & cff2*DiaRVfrc(i,j,nnew,idiag)+ &
1910!! & cff3*DiaRVfrc(i,j,nstp,idiag)
1911!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
1912!! & DiaV2rhs(i,j,idiag)
1913!! END DO
1914# endif
1915!^ tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
1916!^
1917 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_rv(i,j,0,nstp)
1918 ad_rv(i,j,0,nstp)=0.0_r8
1919!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
1920!^ & cff1*tl_rvfrc(i,j)- &
1921!^ & cff2*tl_rv(i,j,0,nnew)+ &
1922!^ & cff3*tl_rv(i,j,0,nstp)
1923!^
1924 ad_rvfrc(i,j)=ad_rvfrc(i,j)+cff1*ad_rhs_vbar(i,j)
1925 ad_rv(i,j,0,nnew)=ad_rv(i,j,0,nnew)- &
1926 & cff2*ad_rhs_vbar(i,j)
1927 ad_rv(i,j,0,nstp)=ad_rv(i,j,0,nstp)+ &
1928 & cff3*ad_rhs_vbar(i,j)
1929!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
1930!^
1931 ad_rhs_vbar(i,j)=ad_rhs_vbar(i,j)-ad_rvfrc(i,j)
1932 END DO
1933 END DO
1934 DO j=jstr,jend
1935 DO i=istru,iend
1936# ifdef DIAGNOSTICS_UV
1937!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
1938!! DiaU2rhs(i,j,M2bstr)=cff1*DiaRUfrc(i,j,3,M2bstr)- &
1939!! & cff2*DiaRUfrc(i,j,nnew,M2bstr)+ &
1940!! & cff3*DiaRUfrc(i,j,nstp,M2bstr)
1941!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
1942!! DiaU2rhs(i,j,M2sstr)=cff1*DiaRUfrc(i,j,3,M2sstr)- &
1943!! & cff2*DiaRUfrc(i,j,nnew,M2sstr)+ &
1944!! & cff3*DiaRUfrc(i,j,nstp,M2sstr)
1945!! DO idiag=1,M2pgrd
1946!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
1947!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
1948!! & cff1*DiaRUfrc(i,j,3,idiag)- &
1949!! & cff2*DiaRUfrc(i,j,nnew,idiag)+ &
1950!! & cff3*DiaRUfrc(i,j,nstp,idiag)
1951!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
1952!! & DiaU2rhs(i,j,idiag)
1953!! END DO
1954# endif
1955!^ tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
1956!^
1957 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_ru(i,j,0,nstp)
1958 ad_ru(i,j,0,nstp)=0.0_r8
1959!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
1960!^ & cff1*tl_rufrc(i,j)- &
1961!^ & cff2*tl_ru(i,j,0,nnew)+ &
1962!^ & cff3*tl_ru(i,j,0,nstp)
1963!^
1964 ad_rufrc(i,j)=ad_rufrc(i,j)+cff1*ad_rhs_ubar(i,j)
1965 ad_ru(i,j,0,nnew)=ad_ru(i,j,0,nnew)- &
1966 & cff2*ad_rhs_ubar(i,j)
1967 ad_ru(i,j,0,nstp)=ad_ru(i,j,0,nstp)+ &
1968 & cff3*ad_rhs_ubar(i,j)
1969!^ tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
1970!^
1971 ad_rhs_ubar(i,j)=ad_rhs_ubar(i,j)-ad_rufrc(i,j)
1972 END DO
1973 END DO
1974 END IF
1975 ELSE
1976 DO j=jstrv,jend
1977 DO i=istr,iend
1978# ifdef DIAGNOSTICS_UV
1979!! DiaV2rhs(i,j,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
1980!! DiaV2rhs(i,j,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
1981!! DO idiag=1,M2pgrd
1982!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
1983!! & DiaRVfrc(i,j,3,idiag)
1984!! END DO
1985# endif
1986!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_rvfrc(i,j)
1987!^
1988 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_rhs_vbar(i,j)
1989 END DO
1990 END DO
1991 DO j=jstr,jend
1992 DO i=istru,iend
1993# ifdef DIAGNOSTICS_UV
1994!! DiaU2rhs(i,j,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
1995!! DiaU2rhs(i,j,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
1996!! DO idiag=1,M2pgrd
1997!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
1998!! & DiaRUfrc(i,j,3,idiag)
1999!! END DO
2000# endif
2001!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_rufrc(i,j)
2002!^
2003 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_rhs_ubar(i,j)
2004 END DO
2005 END DO
2006 END IF
2007#else
2008!^
2009!^----------------------------------------------------------------------
2010!^ Add in surface momentum stress.
2011!^----------------------------------------------------------------------
2012!^
2013 DO j=jstr,jend
2014 DO i=istru,iend
2015# ifdef DIAGNOSTICS_UV
2016!! DiaU2rhs(i,j,M2sstr)=fac
2017# endif
2018!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac
2019!^
2020 ad_fac=ad_fac+ad_rhs_ubar(i,j)
2021!^ tl_fac=tl_sustr(i,j)*om_u(i,j)*on_u(i,j)
2022!^
2023 ad_sustr(i,j)=ad_sustr(i,j)+om_u(i,j)*on_u(i,j)*ad_fac
2024 ad_fac=0.0_r8
2025 END DO
2026 END DO
2027 DO j=jstrv,jend
2028 DO i=istr,iend
2029# ifdef DIAGNOSTICS_UV
2030!! DiaV2rhs(i,j,M2sstr)=fac
2031# endif
2032!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_fac
2033!^
2034 ad_fac=ad_fac+ad_rhs_vbar(i,j)
2035!^ tl_fac=tl_svstr(i,j)*om_v(i,j)*on_v(i,j)
2036!^
2037 ad_svstr(i,j)=ad_svstr(i,j)+om_v(i,j)*on_v(i,j)*ad_fac
2038 ad_fac=0.0_r8
2039 END DO
2040 END DO
2041#endif
2042!
2043!-----------------------------------------------------------------------
2044! Add in adjoint nudging of 2D momentum climatology.
2045!-----------------------------------------------------------------------
2046!
2047 IF (lnudgem2clm(ng)) THEN
2048 DO j=jstrv,jend
2049 DO i=istr,iend
2050 cff=0.25_r8*(clima(ng)%M2nudgcof(i,j-1)+ &
2051 & clima(ng)%M2nudgcof(i,j ))* &
2052 & om_v(i,j)*on_v(i,j)
2053!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
2054!^ & cff*((Drhs(i,j-1)+Drhs(i,j))* &
2055!^ & (-tl_vbar(i,j,krhs))+ &
2056!^ & (tl_Drhs(i,j-1)+tl_Drhs(i,j))* &
2057!^ & (CLIMA(ng)%vbarclm(i,j)-
2058!^ & vbar(i,j,krhs)))
2059!^
2060 adfac=cff*ad_rhs_vbar(i,j)
2061 adfac1=adfac*(drhs(i,j-1)+drhs(i,j))
2062 adfac2=adfac*(clima(ng)%vbarclm(i,j)-vbar(i,j,krhs))
2063 ad_vbar(i,j,krhs)=ad_vbar(i,j,krhs)-adfac1
2064 ad_drhs(i,j-1)=ad_drhs(i,j-1)+adfac2
2065 ad_drhs(i,j )=ad_drhs(i,j )+adfac2
2066 END DO
2067 END DO
2068 DO j=jstr,jend
2069 DO i=istru,iend
2070 cff=0.25_r8*(clima(ng)%M2nudgcof(i-1,j)+ &
2071 & clima(ng)%M2nudgcof(i ,j))* &
2072 & om_u(i,j)*on_u(i,j)
2073!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
2074!^ & cff*((Drhs(i-1,j)+Drhs(i,j))* &
2075!^ & (-tl_ubar(i,j,krhs))+ &
2076!^ & (tl_Drhs(i-1,j)+tl_Drhs(i,j))* &
2077!^ & (CLIMA(ng)%ubarclm(i,j)-
2078!^ & ubar(i,j,krhs)))
2079!^
2080 adfac=cff*ad_rhs_ubar(i,j)
2081 adfac1=adfac*(drhs(i-1,j)+drhs(i,j))
2082 adfac2=adfac*(clima(ng)%ubarclm(i,j)-ubar(i,j,krhs))
2083 ad_ubar(i,j,krhs)=ad_ubar(i,j,krhs)-adfac1
2084 ad_drhs(i-1,j)=ad_drhs(i-1,j)+adfac2
2085 ad_drhs(i ,j)=ad_drhs(i ,j)+adfac2
2086 END DO
2087 END DO
2088 END IF
2089
2090#ifndef SOLVE3D
2091!
2092!-----------------------------------------------------------------------
2093! Add in bottom stress.
2094!-----------------------------------------------------------------------
2095!
2096 DO j=jstrv,jend
2097 DO i=istr,iend
2098# ifdef DIAGNOSTICS_UV
2099!! DiaV2rhs(i,j,M2bstr)=-fac
2100# endif
2101!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac
2102!^
2103 ad_fac=ad_fac-ad_rhs_vbar(i,j)
2104!^ tl_fac=tl_bvstr(i,j)*om_v(i,j)*on_v(i,j)
2105!^
2106 ad_bvstr(i,j)=ad_bvstr(i,j)+om_v(i,j)*on_v(i,j)*ad_fac
2107 ad_fac=0.0_r8
2108 END DO
2109 END DO
2110 DO j=jstr,jend
2111 DO i=istru,iend
2112# ifdef DIAGNOSTICS_UV
2113!! DiaU2rhs(i,j,M2bstr)=-fac
2114# endif
2115!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_fac
2116!^
2117 ad_fac=ad_fac-ad_rhs_ubar(i,j)
2118!^ tl_fac=tl_bustr(i,j)*om_u(i,j)*on_u(i,j)
2119!^
2120 ad_bustr(i,j)=ad_bustr(i,j)+om_u(i,j)*on_u(i,j)*ad_fac
2121 ad_fac=0.0_r8
2122 END DO
2123 END DO
2124#else
2125# ifdef DIAGNOSTICS_UV
2126!!
2127!! Initialize the stress term if no bottom friction is defined.
2128!!
2129!! DO j=Jstr,Jend
2130!! DO i=IstrU,Iend
2131!! DiaU2rhs(i,j,M2bstr)=0.0_r8
2132!! END DO
2133!! END DO
2134!! DO j=JstrV,Jend
2135!! DO i=Istr,Iend
2136!! DiaV2rhs(i,j,M2bstr)=0.0_r8
2137!! END DO
2138!! END DO
2139# endif
2140#endif
2141#if defined WEC_MELLOR && \
2142 (!defined SOLVE3D || defined DIAGNOSTICS_UV)
2143!
2144!-----------------------------------------------------------------------
2145! Add in radiation stress terms.
2146!-----------------------------------------------------------------------
2147!
2148 DO j=jstrv,jend
2149 DO i=istr,iend
2150# ifdef DIAGNOSTICS_UV
2151!! DiaV2rhs(i,j,M2hrad)=-cff1
2152# endif
2153# ifndef SOLVE3D
2154!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_cff1-tl_cff2
2155!^
2156 ad_cff2=ad_cff2-ad_rhs_vbar(i,j)
2157 ad_cff1=ad_cff1-ad_rhs_vbar(i,j)
2158# endif
2159!^ tl_cff2=tl_rvlag2d(i,j)
2160!^
2161 ad_rvlag2d(i,j)=ad_rvlag2d(i,j)+ad_cff2
2162 ad_cff2=0.0_r8
2163!^ tl_cff1=tl_rvstr2d(i,j)*om_v(i,j)*on_v(i,j)
2164!^
2165 ad_rvstr2d(i,j)=ad_rvstr2d(i,j)+ &
2166 & om_v(i,j)*on_v(i,j)*ad_cff1
2167 ad_cff1=0.0_r8
2168 END DO
2169 END DO
2170 DO j=jstr,jend
2171 DO i=istru,iend
2172# ifdef DIAGNOSTICS_UV
2173!! DiaU2rhs(i,j,M2hrad)=-cff1
2174# endif
2175# ifndef SOLVE3D
2176!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_cff1-tl_cff2
2177!^
2178 ad_cff2=ad_cff2-ad_rhs_ubar(i,j)
2179 ad_cff1=ad_cff1-ad_rhs_ubar(i,j)
2180# endif
2181!^ tl_cff2=tl_rulag2d(i,j)
2182!^
2183 ad_rulag2d(i,j)=ad_rulag2d(i,j)+ad_cff2
2184 ad_cff2=0.0_r8
2185!^ tl_cff1=tl_rustr2d(i,j)*om_u(i,j)*on_u(i,j)
2186!^
2187 ad_rustr2d(i,j)=ad_rustr2d(i,j)+ &
2188 & om_u(i,j)*on_u(i,j)*ad_cff1
2189 ad_cff1=0.0_r8
2190 END DO
2191 END DO
2192#endif
2193#if defined UV_VIS2 || defined UV_VIS4
2194!
2195!-----------------------------------------------------------------------
2196! Compute basic state total depth at PSI-points.
2197!-----------------------------------------------------------------------
2198!
2199# ifdef UV_VIS4
2200 DO j=jstrm1,jendp2
2201 DO i=istrm1,iendp2
2202# else
2203 DO j=jstr,jend+1
2204 DO i=istr,iend+1
2205# endif
2206 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2207 & drhs(i,j-1)+drhs(i-1,j-1))
2208 END DO
2209 END DO
2210#endif
2211#ifdef UV_VIS4
2212!
2213!-----------------------------------------------------------------------
2214! Add in adjoint horizontal biharmonic viscosity. The biharmonic
2215! operator is computed by applying the harmonic operator twice.
2216!-----------------------------------------------------------------------
2217!
2218! Compute flux-components of the horizontal divergence of the
2219! BASIC STATE stress tensor (m4 s^-3/2) in XI- and ETA-directions.
2220!
2221 DO j=jstrvm2,jendp1
2222 DO i=istrum2,iendp1
2223 cff=visc4_r(i,j)*0.5_r8* &
2224 & (pmon_r(i,j)* &
2225 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2226 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2227 & pnom_r(i,j)* &
2228 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2229 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))
2230 ufx(i,j)=on_r(i,j)*on_r(i,j)*cff
2231 vfe(i,j)=om_r(i,j)*om_r(i,j)*cff
2232 END DO
2233 END DO
2234 DO j=jstrm1,jendp2
2235 DO i=istrm1,iendp2
2236 cff=visc4_p(i,j)*0.5_r8* &
2237 & (pmon_p(i,j)* &
2238 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2239 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2240 & pnom_p(i,j)* &
2241 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2242 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))
2243# ifdef MASKING
2244 cff=cff*pmask(i,j)
2245# endif
2246 ufe(i,j)=om_p(i,j)*om_p(i,j)*cff
2247 vfx(i,j)=on_p(i,j)*on_p(i,j)*cff
2248 END DO
2249 END DO
2250!
2251! Compute BASIC STATE first harmonic operator (m s^-3/2).
2252!
2253 DO j=jstrm1,jendp1
2254 DO i=istrum1,iendp1
2255 lapu(i,j)=0.125_r8* &
2256 & (pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))* &
2257 & ((pn(i-1,j)+pn(i,j))* &
2258 & (ufx(i,j )-ufx(i-1,j))+ &
2259 & (pm(i-1,j)+pm(i,j))* &
2260 & (ufe(i,j+1)-ufe(i ,j)))
2261 END DO
2262 END DO
2263 DO j=jstrvm1,jendp1
2264 DO i=istrm1,iendp1
2265 lapv(i,j)=0.125_r8* &
2266 & (pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))* &
2267 & ((pn(i,j-1)+pn(i,j))* &
2268 & (vfx(i+1,j)-vfx(i,j ))- &
2269 & (pm(i,j-1)+pm(i,j))* &
2270 & (vfe(i ,j)-vfe(i,j-1)))
2271 END DO
2272 END DO
2273!
2274! Apply boundary conditions (other than periodic) to the first
2275! BASIC STATE harmonic operator. These are gradient or closed
2276! (free slip or no slip) boundary conditions.
2277!
2278 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2279 IF (domain(ng)%Western_Edge(tile)) THEN
2280 IF (ad_lbc(iwest,isubar,ng)%closed) THEN
2281 DO j=jstrm1,jendp1
2282 lapu(istru-1,j)=0.0_r8
2283 END DO
2284 ELSE
2285 DO j=jstrm1,jendp1
2286 lapu(istru-1,j)=lapu(istru,j)
2287 END DO
2288 END IF
2289 IF (ad_lbc(iwest,isvbar,ng)%closed) THEN
2290 DO j=jstrvm1,jendp1
2291 lapv(istr-1,j)=gamma2(ng)*lapv(istr,j)
2292 END DO
2293 ELSE
2294 DO j=jstrvm1,jendp1
2295 lapv(istr-1,j)=0.0_r8
2296 END DO
2297 END IF
2298 END IF
2299 END IF
2300!
2301 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2302 IF (domain(ng)%Eastern_Edge(tile)) THEN
2303 IF (ad_lbc(ieast,isubar,ng)%closed) THEN
2304 DO j=jstrm1,jendp1
2305 lapu(iend+1,j)=0.0_r8
2306 END DO
2307 ELSE
2308 DO j=jstrm1,jendp1
2309 lapu(iend+1,j)=lapu(iend,j)
2310 END DO
2311 END IF
2312 IF (ad_lbc(ieast,isvbar,ng)%closed) THEN
2313 DO j=jstrvm1,jendp1
2314 lapv(iend+1,j)=gamma2(ng)*lapv(iend,j)
2315 END DO
2316 ELSE
2317 DO j=jstrvm1,jendp1
2318 lapv(iend+1,j)=0.0_r8
2319 END DO
2320 END IF
2321 END IF
2322 END IF
2323!
2324 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2325 IF (domain(ng)%Southern_Edge(tile)) THEN
2326 IF (ad_lbc(isouth,isubar,ng)%closed) THEN
2327 DO i=istrum1,iendp1
2328 lapu(i,jstr-1)=gamma2(ng)*lapu(i,jstr)
2329 END DO
2330 ELSE
2331 DO i=istrum1,iendp1
2332 lapu(i,jstr-1)=0.0_r8
2333 END DO
2334 END IF
2335 IF (ad_lbc(isouth,isvbar,ng)%closed) THEN
2336 DO i=istrm1,iendp1
2337 lapv(i,jstrv-1)=0.0_r8
2338 END DO
2339 ELSE
2340 DO i=istrm1,iendp1
2341 lapv(i,jstrv-1)=lapv(i,jstrv)
2342 END DO
2343 END IF
2344 END IF
2345 END IF
2346!
2347 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2348 IF (domain(ng)%Northern_Edge(tile)) THEN
2349 IF (ad_lbc(inorth,isubar,ng)%closed) THEN
2350 DO i=istrum1,iendp1
2351 lapu(i,jend+1)=gamma2(ng)*lapu(i,jend)
2352 END DO
2353 ELSE
2354 DO i=istrum1,iendp1
2355 lapu(i,jend+1)=0.0_r8
2356 END DO
2357 END IF
2358 IF (ad_lbc(inorth,isvbar,ng)%closed) THEN
2359 DO i=istrm1,iendp1
2360 lapv(i,jend+1)=0.0_r8
2361 END DO
2362 ELSE
2363 DO i=istrm1,iendp1
2364 lapv(i,jend+1)=lapv(i,jend)
2365 END DO
2366 END IF
2367 END IF
2368 END IF
2369!
2370 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2371 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2372 IF (domain(ng)%SouthWest_Corner(tile)) THEN
2373 lapu(istr ,jstr-1)=0.5_r8*(lapu(istr+1,jstr-1)+ &
2374 & lapu(istr ,jstr ))
2375 lapv(istr-1,jstr )=0.5_r8*(lapv(istr-1,jstr+1)+ &
2376 & lapv(istr ,jstr ))
2377 END IF
2378 END IF
2379
2380 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2381 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2382 IF (domain(ng)%SouthEast_Corner(tile)) THEN
2383 lapu(iend+1,jstr-1)=0.5_r8*(lapu(iend ,jstr-1)+ &
2384 & lapu(iend+1,jstr ))
2385 lapv(iend+1,jstr )=0.5_r8*(lapv(iend ,jstr )+ &
2386 & lapv(iend+1,jstr+1))
2387 END IF
2388 END IF
2389
2390 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2391 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2392 IF (domain(ng)%NorthWest_Corner(tile)) THEN
2393 lapu(istr ,jend+1)=0.5_r8*(lapu(istr+1,jend+1)+ &
2394 & lapu(istr ,jend ))
2395 lapv(istr-1,jend+1)=0.5_r8*(lapv(istr ,jend+1)+ &
2396 & lapv(istr-1,jend ))
2397 END IF
2398 END IF
2399
2400 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2401 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2402 IF (domain(ng)%NorthEast_Corner(tile)) THEN
2403 lapu(iend+1,jend+1)=0.5_r8*(lapu(iend ,jend+1)+ &
2404 & lapu(iend+1,jend ))
2405 lapv(iend+1,jend+1)=0.5_r8*(lapv(iend ,jend+1)+ &
2406 & lapv(iend+1,jend ))
2407 END IF
2408 END IF
2409!
2410! Add in adjoint biharmocnic viscosity
2411!
2412 DO j=jstrv,jend
2413 DO i=istr,iend
2414# if defined DIAGNOSTICS_UV
2415!! DiaV2rhs(i,j,M2yvis)=-cff2
2416!! DiaV2rhs(i,j,M2xvis)= cff1
2417!! DiaV2rhs(i,j,M2hvis)=fac
2418# endif
2419!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_fac
2420!^
2421 ad_fac=ad_fac+ad_rhs_vbar(i,j)
2422!^ tl_fac=tl_cff1-tl_cff2
2423!^
2424 ad_cff1=ad_cff1+ad_fac
2425 ad_cff2=ad_cff2-ad_fac
2426 ad_fac=0.0_r8
2427!^ tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2428!^ & (tl_VFe(i ,j)-tl_VFe(i,j-1))
2429!^
2430 adfac=0.5_r8*(pm(i,j-1)+pm(i,j))*ad_cff2
2431 ad_vfe(i,j-1)=ad_vfe(i,j-1)-adfac
2432 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2433 ad_cff2=0.0_r8
2434!^ tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2435!^ & (tl_VFx(i+1,j)-tl_VFx(i,j ))
2436!^
2437 adfac=0.5_r8*(pn(i,j-1)+pn(i,j))*ad_cff1
2438 ad_vfx(i ,j)=ad_vfx(i ,j)-adfac
2439 ad_vfx(i+1,j)=ad_vfx(i+1,j)+adfac
2440 ad_cff1=0.0_r8
2441 END DO
2442 END DO
2443 DO j=jstr,jend
2444 DO i=istru,iend
2445# if defined DIAGNOSTICS_UV
2446!! DiaU2rhs(i,j,M2yvis)=cff2
2447!! DiaU2rhs(i,j,M2xvis)=cff1
2448!! DiaU2rhs(i,j,M2hvis)=fac
2449# endif
2450!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac
2451!^
2452 ad_fac=ad_fac+ad_rhs_ubar(i,j)
2453!^ tl_fac=tl_cff1+tl_cff2
2454!^
2455 ad_cff1=ad_cff1+ad_fac
2456 ad_cff2=ad_cff2+ad_fac
2457 ad_fac=0.0_r8
2458!^ tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2459!^ & (UFe(i,j+1)-UFe(i ,j))
2460!^
2461 adfac=0.5_r8*(pm(i-1,j)+pm(i,j))*ad_cff2
2462 ufe(i,j )=ufe(i,j )-adfac
2463 ufe(i,j+1)=ufe(i,j+1)+adfac
2464 ad_cff2=0.0_r8
2465!^ tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2466!^ & (tl_UFx(i,j )-tl_UFx(i-1,j))
2467!^
2468 adfac=0.5_r8*(pn(i-1,j)+pn(i,j))*ad_cff1
2469 ad_ufx(i-1,j)=ad_ufx(i-1,j)-adfac
2470 ad_ufx(i,j )=ad_ufx(i,j )+adfac
2471 ad_cff1=0.0_r8
2472 END DO
2473 END DO
2474!
2475! Compute flux-components of the horizontal divergence of the
2476! adjoint biharmonic stress tensor (m4/s2) in XI- and ETA-directions.
2477!
2478 DO j=jstr,jend+1
2479 DO i=istr,iend+1
2480!^ tl_VFx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2481!^ tl_UFe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2482!^
2483 ad_cff=ad_cff+ &
2484 & on_p(i,j)*on_p(i,j)*ad_vfx(i,j)+ &
2485 & om_p(i,j)*om_p(i,j)*ad_ufe(i,j)
2486 ad_vfx(i,j)=0.0_r8
2487 ad_ufe(i,j)=0.0_r8
2488# ifdef MASKING
2489!^ tl_cff=tl_cff*pmask(i,j)
2490!^
2491 ad_cff=ad_cff*pmask(i,j)
2492# endif
2493!^ tl_cff=visc4_p(i,j)*0.5_r8* &
2494!^ & (tl_Drhs_p(i,j)* &
2495!^ & (pmon_p(i,j)* &
2496!^ & ((pn(i ,j-1)+pn(i ,j))*LapV(i ,j)- &
2497!^ & (pn(i-1,j-1)+pn(i-1,j))*LapV(i-1,j))+ &
2498!^ & pnom_p(i,j)* &
2499!^ & ((pm(i-1,j )+pm(i,j ))*LapU(i,j )- &
2500!^ & (pm(i-1,j-1)+pm(i,j-1))*LapU(i,j-1)))+ &
2501!^ & Drhs_p(i,j)* &
2502!^ & (pmon_p(i,j)* &
2503!^ & ((pn(i ,j-1)+pn(i ,j))*tl_LapV(i ,j)- &
2504!^ & (pn(i-1,j-1)+pn(i-1,j))*tl_LapV(i-1,j))+ &
2505!^ & pnom_p(i,j)* &
2506!^ & ((pm(i-1,j )+pm(i,j ))*tl_LapU(i,j )- &
2507!^ & (pm(i-1,j-1)+pm(i,j-1))*tl_LapU(i,j-1))))
2508!^
2509 adfac=visc4_p(i,j)*0.5_r8*ad_cff
2510 adfac1=adfac*drhs_p(i,j)*pmon_p(i,j)
2511 adfac2=adfac*drhs_p(i,j)*pnom_p(i,j)
2512 ad_drhs_p(i,j)=ad_drhs_p(i,j)+ &
2513 & (pmon_p(i,j)* &
2514 & ((pn(i ,j-1)+pn(i ,j))*lapv(i ,j)- &
2515 & (pn(i-1,j-1)+pn(i-1,j))*lapv(i-1,j))+ &
2516 & pnom_p(i,j)* &
2517 & ((pm(i-1,j )+pm(i,j ))*lapu(i,j )- &
2518 & (pm(i-1,j-1)+pm(i,j-1))*lapu(i,j-1)))* &
2519 & adfac
2520 ad_lapv(i ,j)=ad_lapv(i ,j)+ &
2521 & (pn(i ,j-1)+pn(i ,j))*adfac1
2522 ad_lapv(i-1,j)=ad_lapv(i-1,j)- &
2523 & (pn(i-1,j-1)+pn(i-1,j))*adfac1
2524 ad_lapu(i,j )=ad_lapu(i,j )+ &
2525 & (pm(i-1,j )+pm(i,j ))*adfac2
2526 ad_lapu(i,j-1)=ad_lapu(i,j-1)- &
2527 & (pm(i-1,j-1)+pm(i,j-1))*adfac2
2528 ad_cff=0.0_r8
2529 END DO
2530 END DO
2531 DO j=jstrv-1,jend
2532 DO i=istru-1,iend
2533!^ tl_VFe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2534!^ tl_UFx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2535!^
2536 ad_cff=ad_cff+ &
2537 & om_r(i,j)*om_r(i,j)*ad_vfe(i,j)+ &
2538 & on_r(i,j)*on_r(i,j)*ad_ufx(i,j)
2539 ad_vfe(i,j)=0.0_r8
2540 ad_ufx(i,j)=0.0_r8
2541!^ tl_cff=visc4_r(i,j)*0.5_r8* &
2542!^ & (tl_Drhs(i,j)* &
2543!^ & (pmon_r(i,j)* &
2544!^ & ((pn(i ,j)+pn(i+1,j))*LapU(i+1,j)- &
2545!^ & (pn(i-1,j)+pn(i ,j))*LapU(i ,j))- &
2546!^ & pnom_r(i,j)* &
2547!^ & ((pm(i,j )+pm(i,j+1))*LapV(i,j+1)- &
2548!^ & (pm(i,j-1)+pm(i,j ))*LapV(i,j )))+ &
2549!^ & Drhs(i,j)* &
2550!^ & (pmon_r(i,j)* &
2551!^ & ((pn(i ,j)+pn(i+1,j))*tl_LapU(i+1,j)- &
2552!^ & (pn(i-1,j)+pn(i ,j))*tl_LapU(i ,j))- &
2553!^ & pnom_r(i,j)* &
2554!^ & ((pm(i,j )+pm(i,j+1))*tl_LapV(i,j+1)- &
2555!^ & (pm(i,j-1)+pm(i,j ))*tl_LapV(i,j ))))
2556!^
2557 adfac=visc4_r(i,j)*0.5_r8*ad_cff
2558 adfac1=adfac*drhs(i,j)*pmon_r(i,j)
2559 adfac2=adfac*drhs(i,j)*pnom_r(i,j)
2560 ad_drhs(i,j)=ad_drhs(i,j)+ &
2561 & (pmon_r(i,j)* &
2562 & ((pn(i ,j)+pn(i+1,j))*lapu(i+1,j)- &
2563 & (pn(i-1,j)+pn(i ,j))*lapu(i ,j))- &
2564 & pnom_r(i,j)* &
2565 & ((pm(i,j )+pm(i,j+1))*lapv(i,j+1)- &
2566 & (pm(i,j-1)+pm(i,j ))*lapv(i,j )))*adfac
2567 ad_lapu(i+1,j)=ad_lapu(i+1,j)+ &
2568 & (pn(i ,j)+pn(i+1,j))*adfac1
2569 ad_lapu(i ,j)=ad_lapu(i ,j)- &
2570 & (pn(i-1,j)+pn(i ,j))*adfac1
2571 ad_lapv(i,j+1)=ad_lapv(i,j+1)- &
2572 & (pm(i,j )+pm(i,j+1))*adfac2
2573 ad_lapv(i,j )=ad_lapv(i,j )+ &
2574 & (pm(i,j-1)+pm(i,j ))*adfac2
2575 ad_cff=0.0_r8
2576 END DO
2577 END DO
2578!
2579! Apply boundary conditions (other than periodic) to the first
2580! adjoint harmonic operator. These are gradient or closed (free
2581! slip or no slip) boundary conditions.
2582!
2583 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2584 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2585 IF (domain(ng)%NorthEast_Corner(tile)) THEN
2586!^ tl_LapV(Iend+1,Jend+1)=0.5_r8*(tl_LapV(Iend ,Jend+1)+ &
2587!^ & tl_LapV(Iend+1,Jend ))
2588!^
2589 adfac=0.5_r8*ad_lapv(iend+1,jend+1)
2590 ad_lapv(iend+1,jend )=ad_lapv(iend+1,jend )+adfac
2591 ad_lapv(iend ,jend+1)=ad_lapv(iend ,jend+1)+adfac
2592 ad_lapv(iend+1,jend+1)=0.0_r8
2593!^ tl_LapU(Iend+1,Jend+1)=0.5_r8*(tl_LapU(Iend ,Jend+1)+ &
2594!^ & tl_LapU(Iend+1,Jend ))
2595!^
2596 adfac=0.5_r8*ad_lapu(iend+1,jend+1)
2597 ad_lapu(iend+1,jend )=ad_lapu(iend+1,jend )+adfac
2598 ad_lapu(iend ,jend+1)=ad_lapu(iend ,jend+1)+adfac
2599 ad_lapu(iend+1,jend+1)=0.0_r8
2600 END IF
2601 END IF
2602
2603 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2604 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2605 IF (domain(ng)%NorthWest_Corner(tile)) THEN
2606!^ tl_LapV(Istr-1,Jend+1)=0.5_r8*(tl_LapV(Istr ,Jend+1)+ &
2607!^ & tl_LapV(Istr-1,Jend ))
2608!^
2609 adfac=0.5_r8*ad_lapv(istr-1,jend+1)
2610 ad_lapv(istr-1,jend )=ad_lapv(istr-1,jend )+adfac
2611 ad_lapv(istr ,jend+1)=ad_lapv(istr ,jend+1)+adfac
2612 ad_lapv(istr-1,jend+1)=0.0_r8
2613!^ tl_LapU(Istr ,Jend+1)=0.5_r8*(tl_LapU(Istr+1,Jend+1)+ &
2614!^ & tl_LapU(Istr ,Jend ))
2615!^
2616 adfac=0.5_r8*ad_lapu(istr ,jend+1)
2617 ad_lapu(istr ,jend )=ad_lapu(istr ,jend )+adfac
2618 ad_lapu(istr+1,jend+1)=ad_lapu(istr+1,jend+1)+adfac
2619 ad_lapu(istr ,jend+1)=0.0_r8
2620 END IF
2621 END IF
2622
2623 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2624 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2625 IF (domain(ng)%SouthEast_Corner(tile)) THEN
2626!^ tl_LapV(Iend+1,Jstr )=0.5_r8*(tl_LapV(Iend ,Jstr )+ &
2627!^ & tl_LapV(Iend+1,Jstr+1))
2628!^
2629 adfac=0.5_r8*ad_lapv(iend+1,jstr )
2630 ad_lapv(iend ,jstr )=ad_lapv(iend ,jstr )+adfac
2631 ad_lapv(iend+1,jstr+1)=ad_lapv(iend+1,jstr+1)+adfac
2632 ad_lapv(iend+1,jstr )=0.0_r8
2633!^ tl_LapU(Iend+1,Jstr-1)=0.5_r8*(tl_LapU(Iend ,Jstr-1)+ &
2634!^ & tl_LapU(Iend+1,Jstr ))
2635!^
2636 adfac=0.5_r8*ad_lapu(iend+1,jstr-1)
2637 ad_lapu(iend ,jstr-1)=ad_lapu(iend ,jstr-1)+adfac
2638 ad_lapu(iend+1,jstr )=ad_lapu(iend+1,jstr )+adfac
2639 ad_lapu(iend+1,jstr-1)=0.0_r8
2640 END IF
2641 END IF
2642
2643 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2644 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2645 IF (domain(ng)%SouthWest_Corner(tile)) THEN
2646!^ tl_LapV(Istr-1,Jstr )=0.5_r8*(tl_LapV(Istr-1,Jstr+1)+ &
2647!^ & tl_LapV(Istr ,Jstr ))
2648!^
2649 adfac=0.5_r8*ad_lapv(istr-1,jstr )
2650 ad_lapv(istr ,jstr )=ad_lapv(istr ,jstr )+adfac
2651 ad_lapv(istr-1,jstr+1)=ad_lapv(istr-1,jstr+1)+adfac
2652 ad_lapv(istr-1,jstr )=0.0_r8
2653!^ tl_LapU(Istr ,Jstr-1)=0.5_r8*(tl_LapU(Istr+1,Jstr-1)+ &
2654!^ & tl_LapU(Istr ,Jstr ))
2655!^
2656 adfac=0.5_r8*ad_lapu(istr ,jstr-1)
2657 ad_lapu(istr+1,jstr-1)=ad_lapu(istr+1,jstr-1)+adfac
2658 ad_lapu(istr ,jstr )=ad_lapu(istr ,jstr )+adfac
2659 ad_lapu(istr ,jstr-1)=0.0_r8
2660 END IF
2661 END IF
2662!
2663 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2664 IF (domain(ng)%Northern_Edge(tile)) THEN
2665 IF (ad_lbc(inorth,isvbar,ng)%closed) THEN
2666 DO i=istrm1,iendp1
2667!^ tl_LapV(i,Jend+1)=0.0_r8
2668!^
2669 ad_lapv(i,jend+1)=0.0_r8
2670 END DO
2671 ELSE
2672 DO i=istrm1,iendp1
2673!^ tl_LapV(i,Jend+1)=tl_LapV(i,Jend)
2674!^
2675 ad_lapv(i,jend)=ad_lapv(i,jend)+ad_lapv(i,jend+1)
2676 ad_lapv(i,jend+1)=0.0_r8
2677 END DO
2678 END IF
2679 IF (ad_lbc(inorth,isubar,ng)%closed) THEN
2680 DO i=istrum1,iendp1
2681!^ tl_LapU(i,Jend+1)=gamma2(ng)*tl_LapU(i,Jend)
2682!^
2683 ad_lapu(i,jend)=ad_lapu(i,jend)+ &
2684 & gamma2(ng)*ad_lapu(i,jend+1)
2685 ad_lapu(i,jend+1)=0.0_r8
2686 END DO
2687 ELSE
2688 DO i=istrum1,iendp1
2689!^ tl_LapU(i,Jend+1)=0.0_r8
2690!^
2691 ad_lapu(i,jend+1)=0.0_r8
2692 END DO
2693 END IF
2694 END IF
2695 END IF
2696!
2697 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2698 IF (domain(ng)%Southern_Edge(tile)) THEN
2699 IF (ad_lbc(isouth,isvbar,ng)%closed) THEN
2700 DO i=istrm1,iendp1
2701!^ tl_LapV(i,JstrV-1)=0.0_r8
2702!^
2703 ad_lapv(i,jstrv-1)=0.0_r8
2704 END DO
2705 ELSE
2706 DO i=istrm1,iendp1
2707!^ tl_LapV(i,JstrV-1)=tl_LapV(i,JstrV)
2708!^
2709 ad_lapv(i,jstrv)=ad_lapv(i,jstrv)+ad_lapv(i,jstrv-1)
2710 ad_lapv(i,jstrv-1)=0.0_r8
2711 END DO
2712 END IF
2713 IF (ad_lbc(isouth,isubar,ng)%closed) THEN
2714 DO i=istrum1,iendp1
2715!^ tl_LapU(i,Jstr-1)=gamma2(ng)*tl_LapU(i,Jstr)
2716!^
2717 ad_lapu(i,jstr)=ad_lapu(i,jstr)+ &
2718 & gamma2(ng)*ad_lapu(i,jstr-1)
2719 ad_lapu(i,jstr-1)=0.0_r8
2720 END DO
2721 ELSE
2722 DO i=istrum1,iendp1
2723!^ tl_LapU(i,Jstr-1)=0.0_r8
2724!^
2725 ad_lapu(i,jstr-1)=0.0_r8
2726 END DO
2727 END IF
2728 END IF
2729 END IF
2730!
2731 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2732 IF (domain(ng)%Eastern_Edge(tile)) THEN
2733 IF (ad_lbc(ieast,isvbar,ng)%closed) THEN
2734 DO j=jstrvm1,jendp1
2735!^ tl_LapV(Iend+1,j)=gamma2(ng)*tl_LapV(Iend,j)
2736!^
2737 ad_lapv(iend,j)=ad_lapv(iend,j)+ &
2738 & gamma2(ng)*ad_lapv(iend+1,j)
2739 ad_lapv(iend+1,j)=0.0_r8
2740 END DO
2741 ELSE
2742 DO j=jstrvm1,jendp1
2743!^ tl_LapV(Iend+1,j)=0.0_r8
2744!^
2745 ad_lapv(iend+1,j)=0.0_r8
2746 END DO
2747 END IF
2748 IF (ad_lbc(ieast,isubar,ng)%closed) THEN
2749 DO j=jstrm1,jendp1
2750!^ tl_LapU(Iend+1,j)=0.0_r8
2751!^
2752 ad_lapu(iend+1,j)=0.0_r8
2753 END DO
2754 ELSE
2755 DO j=jstrm1,jendp1
2756!^ tl_LapU(Iend+1,j)=tl_LapU(Iend,j)
2757!^
2758 ad_lapu(iend,j)=ad_lapu(iend,j)+ad_lapu(iend+1,j)
2759 ad_lapu(iend+1,j)=0.0_r8
2760 END DO
2761 END IF
2762 END IF
2763 END IF
2764!
2765 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2766 IF (domain(ng)%Western_Edge(tile)) THEN
2767 IF (ad_lbc(iwest,isvbar,ng)%closed) THEN
2768 DO j=jstrvm1,jendp1
2769!^ tl_LapV(Istr-1,j)=gamma2(ng)*tl_LapV(Istr,j)
2770!^
2771 ad_lapv(istr,j)=ad_lapv(istr,j)+ &
2772 & gamma2(ng)*ad_lapv(istr-1,j)
2773 ad_lapv(istr-1,j)=0.0_r8
2774 END DO
2775 ELSE
2776 DO j=jstrvm1,jendp1
2777!^ tl_LapV(Istr-1,j)=0.0_r8
2778!^
2779 ad_lapv(istr-1,j)=0.0_r8
2780 END DO
2781 END IF
2782 IF (ad_lbc(iwest,isubar,ng)%closed) THEN
2783 DO j=jstrm1,jendp1
2784!^ tl_LapU(IstrU-1,j)=0.0_r8
2785!^
2786 ad_lapu(istru-1,j)=0.0_r8
2787 END DO
2788 ELSE
2789 DO j=jstrm1,jendp1
2790!^ tl_LapU(IstrU-1,j)=tl_LapU(IstrU,j)
2791!^
2792 ad_lapu(istru,j)=ad_lapu(istru,j)+ad_lapu(istru-1,j)
2793 ad_lapu(istru-1,j)=0.0_r8
2794 END DO
2795 END IF
2796 END IF
2797 END IF
2798!
2799! Compute adjoint first harmonic operator (m s^-3/2).
2800!
2801 DO j=jstrvm1,jendp1
2802 DO i=istrm1,iendp1
2803!^ tl_LapV(i,j)=0.125_r8* &
2804!^ & (pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))* &
2805!^ & ((pn(i,j-1)+pn(i,j))* &
2806!^ & (tl_VFx(i+1,j)-tl_VFx(i,j ))- &
2807!^ & (pm(i,j-1)+pm(i,j))* &
2808!^ & (tl_VFe(i ,j)-tl_VFe(i,j-1)))
2809!^
2810 adfac=0.125_r8*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))* &
2811 & ad_lapv(i,j)
2812 adfac1=adfac*(pn(i,j-1)+pn(i,j))
2813 adfac2=adfac*(pm(i,j-1)+pm(i,j))
2814 ad_vfx(i ,j)=ad_vfx(i ,j)-adfac1
2815 ad_vfx(i+1,j)=ad_vfx(i+1,j)+adfac1
2816 ad_vfe(i,j )=ad_vfe(i,j )-adfac2
2817 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac2
2818 ad_lapv(i,j)=0.0_r8
2819 END DO
2820 END DO
2821!
2822 DO j=jstrm1,jendp1
2823 DO i=istrum1,iendp1
2824!^ tl_LapU(i,j)=0.125_r8* &
2825!^ & (pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))* &
2826!^ & ((pn(i-1,j)+pn(i,j))* &
2827!^ & (tl_UFx(i,j )-tl_UFx(i-1,j))+ &
2828!^ & (pm(i-1,j)+pm(i,j))* &
2829!^ & (tl_UFe(i,j+1)-tl_UFe(i ,j)))
2830!^
2831 adfac=0.125_r8*(pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))* &
2832 & ad_lapu(i,j)
2833 adfac1=adfac*(pn(i-1,j)+pn(i,j))
2834 adfac2=adfac*(pm(i-1,j)+pm(i,j))
2835 ad_ufx(i-1,j)=ad_ufx(i-1,j)-adfac1
2836 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac1
2837 ad_ufe(i,j+1)=ad_ufe(i,j+1)+adfac2
2838 ad_ufe(i,j )=ad_ufe(i,j )-adfac2
2839 ad_lapu(i,j)=0.0_r8
2840 END DO
2841 END DO
2842!
2843! Compute flux-components of the adjoint horizontal divergence of the
2844! stress tensor (m4 s^-3/2) in XI- and ETA-directions. It is assumed
2845! here that "visc4_r" and "visc4_p" are the squared root of the
2846! biharmonic viscosity coefficient. For momentum balance purposes,
2847! the total thickness "D" appears only when computing the second
2848! harmonic operator.
2849!
2850 DO j=jstrm1,jendp2
2851 DO i=istrm1,iendp2
2852!^ tl_VFx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2853!^ tl_UFe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2854!^
2855 ad_cff=ad_cff+ &
2856 & on_p(i,j)*on_p(i,j)*ad_vfx(i,j)+ &
2857 & om_p(i,j)*om_p(i,j)*ad_ufe(i,j)
2858 ad_vfx(i,j)=0.0_r8
2859 ad_ufe(i,j)=0.0_r8
2860# ifdef MASKING
2861!^ tl_cff=tl_cff*pmask(i,j)
2862!^
2863 ad_cff=ad_cff*pmask(i,j)
2864# endif
2865!^ tl_cff=visc4_p(i,j)*0.5_r8* &
2866!^ & (pmon_p(i,j)* &
2867!^ & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2868!^ & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2869!^ & pnom_p(i,j)* &
2870!^ & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2871!^ & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs)))
2872!^
2873 adfac=visc4_p(i,j)*0.5_r8*ad_cff
2874 adfac1=adfac*pmon_p(i,j)
2875 adfac2=adfac*pnom_p(i,j)
2876 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)- &
2877 & (pn(i-1,j-1)+pn(i-1,j))*adfac1
2878 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+ &
2879 & (pn(i ,j-1)+pn(i ,j))*adfac1
2880 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)- &
2881 & (pm(i-1,j-1)+pm(i,j-1))*adfac2
2882 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+ &
2883 & (pm(i-1,j )+pm(i,j ))*adfac2
2884 ad_cff=0.0_r8
2885 END DO
2886 END DO
2887 DO j=jstrvm2,jendp1
2888 DO i=istrum2,iendp1
2889!^ tl_VFe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2890!^ tl_UFx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2891!^
2892 ad_cff=ad_cff+ &
2893 & om_r(i,j)*om_r(i,j)*ad_vfe(i,j)+ &
2894 & on_r(i,j)*on_r(i,j)*ad_ufx(i,j)
2895 ad_vfe(i,j)=0.0_r8
2896 ad_ufx(i,j)=0.0_r8
2897!^ tl_cff=visc4_r(i,j)*0.5_r8* &
2898!^ & (pmon_r(i,j)* &
2899!^ & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2900!^ & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2901!^ & pnom_r(i,j)* &
2902!^ & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2903!^ & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs)))
2904!^
2905 adfac=visc4_r(i,j)*0.5_r8*ad_cff
2906 adfac1=adfac*pmon_r(i,j)
2907 adfac2=adfac*pnom_r(i,j)
2908 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+ &
2909 & (pn(i ,j)+pn(i+1,j))*adfac1
2910 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)- &
2911 & (pn(i-1,j)+pn(i ,j))*adfac1
2912 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)- &
2913 & (pm(i,j )+pm(i,j+1))*adfac2
2914 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+ &
2915 & (pm(i,j-1)+pm(i,j ))*adfac2
2916 ad_cff=0.0_r8
2917 END DO
2918 END DO
2919#endif
2920#ifdef UV_VIS2
2921!
2922!-----------------------------------------------------------------------
2923! Add in adjoint horizontal harmonic viscosity.
2924!-----------------------------------------------------------------------
2925!
2926! Add in harmonic viscosity.
2927!
2928 DO j=jstrv,jend
2929 DO i=istr,iend
2930# if defined DIAGNOSTICS_UV
2931!! DiaV2rhs(i,j,M2yvis)=-cff2
2932!! DiaV2rhs(i,j,M2xvis)= cff1
2933!! DiaV2rhs(i,j,M2hvis)=fac
2934# endif
2935!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_fac
2936!^
2937 ad_fac=ad_fac+ad_rhs_vbar(i,j)
2938!^ tl_fac=tl_cff1-tl_cff2
2939!^
2940 ad_cff1=ad_cff1+ad_fac
2941 ad_cff2=ad_cff2-ad_fac
2942 ad_fac=0.0_r8
2943!^ tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2944!^ & (tl_VFe(i ,j)-tl_VFe(i,j-1))
2945!^
2946 adfac=0.5_r8*(pm(i,j-1)+pm(i,j))*ad_cff2
2947 ad_vfe(i,j-1)=ad_vfe(i,j-1)-adfac
2948 ad_vfe(i ,j)=ad_vfe(i ,j)+adfac
2949 ad_cff2=0.0_r8
2950!^ tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2951!^ & (tl_VFx(i+1,j)-tl_VFx(i,j ))
2952!^
2953 adfac=0.5_r8*(pn(i,j-1)+pn(i,j))*ad_cff1
2954 ad_vfx(i ,j)=ad_vfx(i ,j)-adfac
2955 ad_vfx(i+1,j)=ad_vfx(i+1,j)+adfac
2956 ad_cff1=0.0_r8
2957 END DO
2958 END DO
2959 DO j=jstr,jend
2960 DO i=istru,iend
2961# if defined DIAGNOSTICS_UV
2962!! DiaU2rhs(i,j,M2yvis)=cff2
2963!! DiaU2rhs(i,j,M2xvis)=cff1
2964!! DiaU2rhs(i,j,M2hvis)=fac
2965# endif
2966!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac
2967!^
2968 ad_fac=ad_fac+ad_rhs_ubar(i,j)
2969!^ tl_fac=tl_cff1+tl_cff2
2970!^
2971 ad_cff1=ad_cff1+ad_fac
2972 ad_cff2=ad_cff2+ad_fac
2973 ad_fac=0.0_r8
2974!^ tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2975!^ & (tl_UFe(i,j+1)-tl_UFe(i ,j))
2976!^
2977 adfac=0.5_r8*(pm(i-1,j)+pm(i,j))*ad_cff2
2978 ad_ufe(i,j )=ad_ufe(i,j )-adfac
2979 ad_ufe(i,j+1)=ad_ufe(i,j+1)+adfac
2980 ad_cff2=0.0_r8
2981!^ tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2982!^ & (tl_UFx(i,j )-tl_UFx(i-1,j))
2983!^
2984 adfac=0.5_r8*(pn(i-1,j)+pn(i,j))*ad_cff1
2985 ad_ufx(i-1,j)=ad_ufx(i-1,j)-adfac
2986 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2987 ad_cff1=0.0_r8
2988 END DO
2989 END DO
2990!
2991! Compute flux-components of the adjoint horizontal divergence of the
2992! stress tensor (m5/s2) in XI- and ETA-directions.
2993!
2994 DO j=jstr,jend+1
2995 DO i=istr,iend+1
2996!^ tl_VFx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2997!^ tl_UFe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2998!^
2999 ad_cff=ad_cff+ &
3000 & on_p(i,j)*on_p(i,j)*ad_vfx(i,j)+ &
3001 & om_p(i,j)*om_p(i,j)*ad_ufe(i,j)
3002 ad_vfx(i,j)=0.0_r8
3003 ad_ufe(i,j)=0.0_r8
3004# ifdef MASKING
3005!^ tl_cff=tl_cff*pmask(i,j)
3006!^
3007 ad_cff=ad_cff*pmask(i,j)
3008# endif
3009!^ tl_cff=visc2_p(i,j)*0.5_r8* &
3010!^ & (tl_Drhs_p(i,j)* &
3011!^ & (pmon_p(i,j)* &
3012!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
3013!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
3014!^ & pnom_p(i,j)* &
3015!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
3016!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))+ &
3017!^ & Drhs_p(i,j)* &
3018!^ & (pmon_p(i,j)* &
3019!^ & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
3020!^ & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
3021!^ & pnom_p(i,j)* &
3022!^ & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
3023!^ & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs))))
3024!^
3025 adfac=visc2_p(i,j)*0.5_r8*ad_cff
3026 adfac1=adfac*drhs_p(i,j)
3027 adfac2=adfac1*pmon_p(i,j)
3028 adfac3=adfac1*pnom_p(i,j)
3029 ad_drhs_p(i,j)=ad_drhs_p(i,j)+ &
3030 & (pmon_p(i,j)* &
3031 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
3032 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
3033 & pnom_p(i,j)* &
3034 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
3035 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))*&
3036 & adfac
3037 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)- &
3038 & (pn(i-1,j-1)+pn(i-1,j))*adfac2
3039 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+ &
3040 & (pn(i ,j-1)+pn(i ,j))*adfac2
3041 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)- &
3042 & (pm(i-1,j-1)+pm(i,j-1))*adfac3
3043 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+ &
3044 & (pm(i-1,j )+pm(i,j ))*adfac3
3045 ad_cff=0.0_r8
3046 END DO
3047 END DO
3048 DO j=jstrv-1,jend
3049 DO i=istru-1,iend
3050!^ tl_VFe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
3051!^ tl_UFx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
3052!^
3053 ad_cff=ad_cff+ &
3054 & om_r(i,j)*om_r(i,j)*ad_vfe(i,j)+ &
3055 & on_r(i,j)*on_r(i,j)*ad_ufx(i,j)
3056 ad_vfe(i,j)=0.0_r8
3057 ad_ufx(i,j)=0.0_r8
3058!^ tl_cff=visc2_r(i,j)*0.5_r8* &
3059!^ & (tl_Drhs(i,j)* &
3060!^ & (pmon_r(i,j)* &
3061!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
3062!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
3063!^ & pnom_r(i,j)* &
3064!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
3065!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))+ &
3066!^ & Drhs(i,j)* &
3067!^ & (pmon_r(i,j)* &
3068!^ & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
3069!^ & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
3070!^ & pnom_r(i,j)* &
3071!^ & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
3072!^ & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs))))
3073!^
3074 adfac=visc2_r(i,j)*0.5_r8*ad_cff
3075 adfac1=adfac*drhs(i,j)
3076 adfac2=adfac1*pmon_r(i,j)
3077 adfac3=adfac1*pnom_r(i,j)
3078 ad_drhs(i,j)=ad_drhs(i,j)+ &
3079 & (pmon_r(i,j)* &
3080 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
3081 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
3082 & pnom_r(i,j)* &
3083 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
3084 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))* &
3085 & adfac
3086 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)- &
3087 & (pn(i-1,j)+pn(i ,j))*adfac2
3088 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+ &
3089 & (pn(i ,j)+pn(i+1,j))*adfac2
3090 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+ &
3091 & (pm(i,j-1)+pm(i,j ))*adfac3
3092 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)- &
3093 & (pm(i,j )+pm(i,j+1))*adfac3
3094 ad_cff=0.0_r8
3095 END DO
3096 END DO
3097#endif
3098#if defined UV_VIS2 || defined UV_VIS4
3099!
3100!-----------------------------------------------------------------------
3101! If horizontal mixing, compute adjoint total depth at PSI-points.
3102!-----------------------------------------------------------------------
3103!
3104# ifdef UV_VIS4
3105 DO j=jstrm1,jendp2
3106 DO i=istrm1,iendp2
3107# else
3108 DO j=jstr,jend+1
3109 DO i=istr,iend+1
3110# endif
3111 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
3112 & drhs(i,j-1)+drhs(i-1,j-1))
3113!^ tl_Drhs_p(i,j)=0.25_r8*(tl_Drhs(i,j )+tl_Drhs(i-1,j )+ &
3114!^ & tl_Drhs(i,j-1)+tl_Drhs(i-1,j-1))
3115!^
3116 adfac=0.25_r8*ad_drhs_p(i,j)
3117 ad_drhs(i-1,j )=ad_drhs(i-1,j )+adfac
3118 ad_drhs(i ,j )=ad_drhs(i ,j )+adfac
3119 ad_drhs(i-1,j-1)=ad_drhs(i-1,j-1)+adfac
3120 ad_drhs(i ,j-1)=ad_drhs(i ,j-1)+adfac
3121 ad_drhs_p(i,j)=0.0_r8
3122 END DO
3123 END DO
3124#endif
3125#if defined CURVGRID && defined UV_ADV
3126!
3127!-----------------------------------------------------------------------
3128! Add in curvilinear transformation terms.
3129!-----------------------------------------------------------------------
3130!
3131 DO j=jstrv,jend
3132 DO i=istr,iend
3133# if defined DIAGNOSTICS_UV
3134!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
3135!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
3136!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
3137!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
3138# endif
3139!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac1
3140!^
3141 ad_fac1=ad_fac1-ad_rhs_vbar(i,j)
3142!^ tl_fac1=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
3143!^
3144 adfac=0.5_r8*ad_fac1
3145 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
3146 ad_vfe(i,j )=ad_vfe(i,j )+adfac
3147 ad_fac1=0.0_r8
3148 END DO
3149 END DO
3150 DO j=jstr,jend
3151 DO i=istru,iend
3152# if defined DIAGNOSTICS_UV
3153!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
3154!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
3155!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
3156!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
3157# endif
3158!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac1
3159!^
3160 ad_fac1=ad_fac1+ad_rhs_ubar(i,j)
3161!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
3162!^
3163 adfac=0.5_r8*ad_fac1
3164 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
3165 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
3166 ad_fac1=0.0_r8
3167 END DO
3168 END DO
3169 DO j=jstrv-1,jend
3170 DO i=istru-1,iend
3171 cff1=0.5_r8*(vbar(i,j ,krhs)+ &
3172# ifdef WEC_MELLOR
3173 & vbar_stokes(i,j )+ &
3174 & vbar_stokes(i,j+1)+ &
3175# endif
3176 & vbar(i,j+1,krhs))
3177 cff2=0.5_r8*(ubar(i ,j,krhs)+ &
3178# ifdef WEC_MELLOR
3179 & ubar_stokes(i ,j)+ &
3180 & ubar_stokes(i+1,j)+ &
3181# endif
3182 & ubar(i+1,j,krhs))
3183 cff3=cff1*dndx(i,j)
3184 cff4=cff2*dmde(i,j)
3185 cff=drhs(i,j)*(cff3-cff4)
3186# if defined DIAGNOSTICS_UV
3187!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
3188!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
3189!! cff=Drhs(i,j)*cff4
3190# endif
3191!^ tl_VFe(i,j)=tl_cff*cff2+cff*tl_cff2
3192!^ tl_UFx(i,j)=tl_cff*cff1+cff*tl_cff1
3193!^
3194 ad_cff=ad_cff+ &
3195 & cff1*ad_ufx(i,j)+ &
3196 & cff2*ad_vfe(i,j)
3197 ad_cff1=ad_cff1+cff*ad_ufx(i,j)
3198 ad_cff2=ad_cff2+cff*ad_vfe(i,j)
3199 ad_ufx(i,j)=0.0_r8
3200 ad_vfe(i,j)=0.0_r8
3201!^ tl_cff=tl_Drhs(i,j)*(cff3-cff4)+ &
3202!^ & Drhs(i,j)*(tl_cff3-tl_cff4)
3203!^
3204 adfac=drhs(i,j)*ad_cff
3205 ad_cff4=ad_cff4-adfac
3206 ad_cff3=ad_cff3+adfac
3207 ad_drhs(i,j)=ad_drhs(i,j)+(cff3-cff4)*ad_cff
3208 ad_cff=0.0_r8
3209!^ tl_cff4=tl_cff2*dmde(i,j)
3210!^
3211 ad_cff2=ad_cff2+dmde(i,j)*ad_cff4
3212 ad_cff4=0.0_r8
3213!^ tl_cff3=tl_cff1*dndx(i,j)
3214!^
3215 ad_cff1=ad_cff1+dndx(i,j)*ad_cff3
3216 ad_cff3=0.0_r8
3217!^ tl_cff2=0.5_r8*(tl_ubar(i ,j,krhs)+ &
3218# ifdef WEC_MELLOR
3219!^ & tl_ubar_stokes(i ,j)+ &
3220!^ & tl_ubar_stokes(i+1,j)+ &
3221# endif
3222!^ & tl_ubar(i+1,j,krhs))
3223!^
3224 adfac=0.5_r8*ad_cff2
3225 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac
3226 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac
3227# ifdef WEC_MELLOR
3228 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
3229 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
3230# endif
3231 ad_cff2=0.0_r8
3232!^ tl_cff1=0.5_r8*(tl_vbar(i,j ,krhs)+ &
3233# ifdef WEC_MELLOR
3234!^ & tl_vbar_stokes(i,j )+ &
3235!^ & tl_vbar_stokes(i,j+1)+ &
3236# endif
3237!^ & tl_vbar(i,j+1,krhs))
3238!^
3239 adfac=0.5_r8*ad_cff1
3240 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac
3241 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac
3242# ifdef WEC_MELLOR
3243 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
3244 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
3245# endif
3246 ad_cff1=0.0_r8
3247 END DO
3248 END DO
3249#endif
3250#ifdef UV_COR
3251!
3252!-----------------------------------------------------------------------
3253! Add in Coriolis term.
3254!-----------------------------------------------------------------------
3255!
3256 DO j=jstrv,jend
3257 DO i=istr,iend
3258# if defined DIAGNOSTICS_UV
3259!! DiaV2rhs(i,j,M2fcor)=-fac1
3260# endif
3261!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac1
3262!^
3263 ad_fac1=ad_fac1-ad_rhs_vbar(i,j)
3264!^ tl_fac1=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
3265!^
3266 adfac=0.5_r8*ad_fac1
3267 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
3268 ad_vfe(i,j )=ad_vfe(i,j )+adfac
3269 ad_fac1=0.0_r8
3270 END DO
3271 END DO
3272 DO j=jstr,jend
3273 DO i=istru,iend
3274# if defined DIAGNOSTICS_UV
3275!! DiaU2rhs(i,j,M2fcor)=fac1
3276# endif
3277!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac1
3278!^
3279 ad_fac1=ad_fac1+ad_rhs_ubar(i,j)
3280!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
3281!^
3282 adfac=0.5_r8*ad_fac1
3283 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
3284 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
3285 ad_fac1=0.0_r8
3286 END DO
3287 END DO
3288 DO j=jstrv-1,jend
3289 DO i=istru-1,iend
3290 cff=0.5_r8*drhs(i,j)*fomn(i,j)
3291!^ tl_VFe(i,j)=tl_cff*(ubar(i ,j,krhs)+ &
3292# ifdef WEC_MELLOR
3293!^ & ubar_stokes(i ,j)+ &
3294!^ & ubar_stokes(i+1,j)+ &
3295# endif
3296!^ & ubar(i+1,j,krhs))+ &
3297!^ & cff*(tl_ubar(i ,j,krhs)+ &
3298# ifdef WEC_MELLOR
3299!^ & tl_ubar_stokes(i ,j)+ &
3300!^ & tl_ubar_stokes(i+1,j)+ &
3301# endif
3302!^ & tl_ubar(i+1,j,krhs))
3303!^
3304 adfac=cff*ad_vfe(i,j)
3305 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac
3306 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac
3307# ifdef WEC_MELLOR
3308 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
3309 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
3310# endif
3311 ad_cff=ad_cff+(ubar(i ,j,krhs)+ &
3312# ifdef WEC_MELLOR
3313 & ubar_stokes(i ,j)+ &
3314 & ubar_stokes(i+1,j)+ &
3315# endif
3316 & ubar(i+1,j,krhs))*ad_vfe(i,j)
3317 ad_vfe(i,j)=0.0_r8
3318!^ tl_UFx(i,j)=tl_cff*(vbar(i,j ,krhs)+ &
3319# ifdef WEC_MELLOR
3320!^ & vbar_stokes(i,j )+ &
3321!^ & vbar_stokes(i,j+1)+ &
3322# endif
3323!^ & vbar(i,j+1,krhs))+ &
3324!^ & cff*(tl_vbar(i,j ,krhs)+ &
3325# ifdef WEC_MELLOR
3326!^ & tl_vbar_stokes(i,j )+ &
3327!^ & tl_vbar_stokes(i,j+1)+ &
3328# endif
3329!^ & tl_vbar(i,j+1,krhs))
3330!^
3331 adfac=cff*ad_ufx(i,j)
3332 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac
3333 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac
3334# ifdef WEC_MELLOR
3335 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
3336 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
3337# endif
3338 ad_cff=ad_cff+(vbar(i,j ,krhs)+ &
3339# ifdef WEC_MELLOR
3340 & vbar_stokes(i,j )+ &
3341 & vbar_stokes(i,j+1)+ &
3342# endif
3343 & vbar(i,j+1,krhs))*ad_ufx(i,j)
3344 ad_ufx(i,j)=0.0_r8
3345!^ tl_cff=0.5_r8*tl_Drhs(i,j)*fomn(i,j)
3346!^
3347 ad_drhs(i,j)=ad_drhs(i,j)+0.5_r8*fomn(i,j)*ad_cff
3348 ad_cff=0.0_r8
3349 END DO
3350 END DO
3351#endif
3352#ifdef UV_ADV
3353!
3354!-----------------------------------------------------------------------
3355! Add in adjoint horizontal advection of momentum.
3356!-----------------------------------------------------------------------
3357!
3358 DO j=jstrv,jend
3359 DO i=istr,iend
3360# if defined DIAGNOSTICS_UV
3361!! DiaV2rhs(i,j,M2hadv)=-fac
3362!! DiaV2rhs(i,j,M2yadv)=-cff2
3363!! DiaV2rhs(i,j,M2xadv)=-cff1
3364# endif
3365!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac
3366!^
3367 ad_fac=ad_fac-ad_rhs_vbar(i,j)
3368!^ tl_fac=tl_cff1+tl_cff2
3369!^
3370 ad_cff1=ad_cff1+ad_fac
3371 ad_cff2=ad_cff2+ad_fac
3372 ad_fac=0.0_r8
3373!^ tl_cff2=tl_VFe(i,j)-tl_VFe(i,j-1)
3374!^
3375 ad_vfe(i,j-1)=ad_vfe(i,j-1)-ad_cff2
3376 ad_vfe(i,j )=ad_vfe(i,j )+ad_cff2
3377 ad_cff2=0.0_r8
3378!^ tl_cff1=tl_VFx(i+1,j)-tl_VFx(i,j)
3379!^
3380 ad_vfx(i ,j)=ad_vfx(i ,j)-ad_cff1
3381 ad_vfx(i+1,j)=ad_vfx(i+1,j)+ad_cff1
3382 ad_cff1=0.0_r8
3383 END DO
3384 END DO
3385 DO j=jstr,jend
3386 DO i=istru,iend
3387# if defined DIAGNOSTICS_UV
3388!! DiaU2rhs(i,j,M2xadv)=-cff1
3389!! DiaU2rhs(i,j,M2yadv)=-cff2
3390!! DiaU2rhs(i,j,M2hadv)=-fac
3391# endif
3392!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_fac
3393!^
3394 ad_fac=ad_fac-ad_rhs_ubar(i,j)
3395!^ tl_fac=tl_cff1+tl_cff2
3396!^
3397 ad_cff1=ad_cff1+ad_fac
3398 ad_cff2=ad_cff2+ad_fac
3399 ad_fac=0.0_r8
3400!^ tl_cff2=tl_UFe(i,j+1)-tl_UFe(i,j)
3401!^
3402 ad_ufe(i,j )=ad_ufe(i,j )-ad_cff2
3403 ad_ufe(i,j+1)=ad_ufe(i,j+1)+ad_cff2
3404 ad_cff2=0.0_r8
3405!^ tl_cff1=tl_UFx(i,j)-tl_UFx(i-1,j)
3406!^
3407 ad_ufx(i-1,j)=ad_ufx(i-1,j)-ad_cff1
3408 ad_ufx(i ,j)=ad_ufx(i ,j)+ad_cff1
3409 ad_cff1=0.0_r8
3410 END DO
3411 END DO
3412# ifdef UV_C2ADVECTION
3413!
3414! Second-order, centered differences advection.
3415!
3416 DO j=jstrv-1,jend
3417 DO i=istr,iend
3418!^ tl_VFe(i,j)=0.25_r8* &
3419!^ & ((tl_DVom(i,j)+tl_DVom(i,j+1))* &
3420!^ & (vbar(i,j ,krhs)+ &
3421# ifdef WEC_MELLOR
3422!^ & vbar_stokes(i,j )+ &
3423!^ & vbar_stokes(i,j+1)+ &
3424# endif
3425!^ & vbar(i,j+1,krhs))+ &
3426!^ & (DVom(i,j)+DVom(i,j+1))* &
3427!^ & (tl_vbar(i,j ,krhs)+ &
3428# ifdef WEC_MELLOR
3429!^ & tl_vbar_stokes(i,j )+ &
3430!^ & tl_vbar_stokes(i,j+1)+ &
3431# endif
3432!^ & tl_vbar(i,j+1,krhs)))
3433!^
3434 adfac=0.25_r8*ad_vfe(i,j)
3435 adfac1=adfac*(vbar(i,j ,krhs)+ &
3436# ifdef WEC_MELLOR
3437 & vbar_stokes(i,j )+ &
3438 & vbar_stokes(i,j+1)+ &
3439# endif
3440 & vbar(i,j+1,krhs))
3441 adfac2=adfac*(dvom(i,j)+dvom(i,j+1))
3442 ad_dvom(i,j )=ad_dvom(i,j )+adfac1
3443 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac1
3444 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac2
3445 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac2
3446# ifdef WEC_MELLOR
3447 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac2
3448 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac2
3449# endif
3450 ad_vfe(i,j)=0.0_r8
3451 END DO
3452 END DO
3453!
3454 DO j=jstrv,jend
3455 DO i=istr,iend+1
3456!^ tl_VFx(i,j)=0.25_r8* &
3457!^ & ((tl_DUon(i,j)+tl_DUon(i,j-1))* &
3458!^ & (vbar(i ,j,krhs)+ &
3459# ifdef WEC_MELLOR
3460!^ & vbar_stokes(i ,j)+ &
3461!^ & vbar_stokes(i-1,j)+ &
3462# endif
3463!^ & vbar(i-1,j,krhs))+ &
3464!^ & (DUon(i,j)+DUon(i,j-1))* &
3465!^ & (tl_vbar(i ,j,krhs)+ &
3466# ifdef WEC_MELLOR
3467!^ & tl_vbar_stokes(i ,j)+ &
3468!^ & tl_vbar_stokes(i-1,j)+ &
3469# endif
3470!^ & tl_vbar(i-1,j,krhs)))
3471!^
3472 adfac=0.25_r8*ad_vfx(i,j)
3473 adfac1=adfac*(vbar(i ,j,krhs)+ &
3474# ifdef WEC_MELLOR
3475 & vbar_stokes(i ,j)+ &
3476 & vbar_stokes(i-1,j)+ &
3477# endif
3478 & vbar(i-1,j,krhs))
3479 adfac2=adfac*(duon(i,j)+duon(i,j-1))
3480 ad_duon(i,j )=ad_duon(i,j )+adfac1
3481 ad_duon(i,j-1)=ad_duon(i,j-1)+adfac1
3482 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+adfac2
3483 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+adfac2
3484# ifdef WEC_MELLOR
3485 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac2
3486 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac2
3487# endif
3488 ad_vfx(i,j)=0.0_r8
3489 END DO
3490 END DO
3491!
3492 DO j=jstr,jend+1
3493 DO i=istru,iend
3494!^ tl_UFe(i,j)=0.25_r8* &
3495!^ & ((tl_DVom(i,j)+tl_DVom(i-1,j))* &
3496!^ & (ubar(i,j ,krhs)+ &
3497# ifdef WEC_MELLOR
3498!^ & ubar_stokes(i,j )+ &
3499!^ & ubar_stokes(i,j-1)+ &
3500# endif
3501!^ & ubar(i,j-1,krhs))+ &
3502!^ & (DVom(i,j)+DVom(i-1,j))* &
3503!^ & (tl_ubar(i,j ,krhs)+
3504# ifdef WEC_MELLOR
3505!^ & tl_ubar_stokes(i,j )+ &
3506!^ & tl_ubar_stokes(i,j-1)+ &
3507# endif
3508!^ & tl_ubar(i,j-1,krhs)))
3509!^
3510 adfac=0.25_r8*ad_ufe(i,j)
3511 adfac1=adfac*(ubar(i,j ,krhs)+ &
3512# ifdef WEC_MELLOR
3513 & ubar_stokes(i,j )+ &
3514 & ubar_stokes(i,j-1)+ &
3515# endif
3516 & ubar(i,j-1,krhs))
3517 adfac2=adfac*(dvom(i,j)+dvom(i-1,j))
3518 ad_dvom(i ,j)=ad_dvom(i ,j)+adfac1
3519 ad_dvom(i-1,j)=ad_dvom(i-1,j)+adfac1
3520 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+adfac2
3521 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+adfac2
3522# ifdef WEC_MELLOR
3523 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+adfac2
3524 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac2
3525# endif
3526 ad_ufe(i,j)=0.0_r8
3527 END DO
3528 END DO
3529!
3530 DO j=jstr,jend
3531 DO i=istru-1,iend
3532!^ tl_UFx(i,j)=0.25_r8* &
3533!^ & ((tl_DUon(i,j)+tl_DUon(i+1,j))* &
3534!^ & (ubar(i ,j,krhs)+ &
3535# ifdef WEC_MELLOR
3536!^ & ubar_stokes(i ,j)+ &
3537!^ & ubar_stokes(i+1,j)+ &
3538# endif
3539!^ & ubar(i+1,j,krhs))+ &
3540!^ & (DUon(i,j)+DUon(i+1,j))* &
3541!^ & (tl_ubar(i ,j,krhs)+ &
3542# ifdef WEC_MELLOR
3543!^ & tl_ubar_stokes(i ,j)+ &
3544!^ & tl_ubar_stokes(i+1,j)+ &
3545# endif
3546!^ & tl_ubar(i+1,j,krhs)))
3547!^
3548 adfac=0.25_r8*ad_ufx(i,j)
3549 adfac1=adfac*(ubar(i ,j,krhs)+ &
3550# ifdef WEC_MELLOR
3551 & ubar_stokes(i ,j)+ &
3552 & ubar_stokes(i+1,j)+ &
3553# endif
3554 & ubar(i+1,j,krhs))
3555 adfac2=adfac*(duon(i,j)+duon(i+1,j))
3556 ad_duon(i ,j)=ad_duon(i ,j)+adfac1
3557 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac1
3558 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac2
3559 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac2
3560# ifdef WEC_MELLOR
3561 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac2
3562 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac2
3563# endif
3564 ad_ufx(i,j)=0.0_r8
3565 END DO
3566 END DO
3567# else
3568!
3569! Fourth-order, centered differences advection.
3570!
3571 DO j=jstrvm1,jendp1
3572 DO i=istr,iend
3573 grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ &
3574# ifdef WEC_MELLOR
3575 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
3576 & vbar_stokes(i,j+1)+ &
3577# endif
3578 & vbar(i,j+1,krhs)
3579 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
3580 END DO
3581 END DO
3582 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3583 IF (domain(ng)%Northern_Edge(tile)) THEN
3584 DO i=istr,iend
3585 grad(i,jend+1)=grad(i,jend)
3586 dgrad(i,jend+1)=dgrad(i,jend)
3587 END DO
3588 END IF
3589 END IF
3590
3591 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3592 IF (domain(ng)%Southern_Edge(tile)) THEN
3593 DO i=istr,iend
3594 grad(i,jstr)=grad(i,jstr+1)
3595 dgrad(i,jstr)=dgrad(i,jstr+1)
3596 END DO
3597 END IF
3598 END IF
3599
3600 cff=1.0_r8/6.0_r8
3601 DO j=jstrv-1,jend
3602 DO i=istr,iend
3603!^ tl_VFe(i,j)=0.25_r8* &
3604!^ & ((tl_vbar(i,j ,krhs)+ &
3605# ifdef WEC_MELLOR
3606!^ & tl_vbar_stokes(i,j )+ &
3607!^ & tl_vbar_stokes(i,j+1)+ &
3608# endif
3609!^ & tl_vbar(i,j+1,krhs)- &
3610!^ & cff*(tl_grad (i,j)+tl_grad (i,j+1)))* &
3611!^ & (DVom(i,j)+DVom(i,j+1)- &
3612!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))+ &
3613!^ & (vbar(i,j ,krhs)+ &
3614# ifdef WEC_MELLOR
3615!^ & vbar_stokes(i,j )+ &
3616!^ & vbar_stokes(i,j+1)+ &
3617# endif
3618!^ & vbar(i,j+1,krhs)- &
3619!^ & cff*(grad (i,j)+grad (i,j+1)))* &
3620!^ & (tl_DVom(i,j)+tl_DVom(i,j+1)- &
3621!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j+1))))
3622!^
3623 adfac=0.25_r8*ad_vfe(i,j)
3624 adfac1=adfac*(dvom(i,j)+dvom(i,j+1)- &
3625 & cff*(dgrad(i,j)+dgrad(i,j+1)))
3626 adfac2=adfac1*cff
3627 adfac3=adfac*(vbar(i,j ,krhs)+ &
3628# ifdef WEC_MELLOR
3629 & vbar_stokes(i,j )+ &
3630 & vbar_stokes(i,j+1)+ &
3631# endif
3632 & vbar(i,j+1,krhs)- &
3633 & cff*(grad(i,j)+grad(i,j+1)))
3634 adfac4=adfac3*cff
3635 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac1
3636 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac1
3637# ifdef WEC_MELLOR
3638 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac1
3639 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac1
3640# endif
3641 ad_grad(i,j )=ad_grad(i,j )-adfac2
3642 ad_grad(i,j+1)=ad_grad(i,j+1)-adfac2
3643 ad_dvom(i,j )=ad_dvom(i,j )+adfac3
3644 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac3
3645 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3646 ad_dgrad(i,j+1)=ad_dgrad(i,j+1)-adfac4
3647 ad_vfe(i,j)=0.0_r8
3648 END DO
3649 END DO
3650 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3651 IF (domain(ng)%Northern_Edge(tile)) THEN
3652 DO i=istr,iend
3653!^ tl_Dgrad(i,Jend+1)=tl_Dgrad(i,Jend)
3654!^
3655 ad_dgrad(i,jend)=ad_dgrad(i,jend)+ad_dgrad(i,jend+1)
3656 ad_dgrad(i,jend+1)=0.0_r8
3657!^ tl_grad (i,Jend+1)=tl_grad (i,Jend)
3658!^
3659 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3660 ad_grad(i,jend+1)=0.0_r8
3661 END DO
3662 END IF
3663 END IF
3664 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3665 IF (domain(ng)%Southern_Edge(tile)) THEN
3666 DO i=istr,iend
3667!^ tl_Dgrad(i,Jstr)=tl_Dgrad(i,Jstr+1)
3668!^
3669 ad_dgrad(i,jstr+1)=ad_dgrad(i,jstr+1)+ad_dgrad(i,jstr)
3670 ad_dgrad(i,jstr)=0.0_r8
3671!^ tl_grad (i,Jstr)=tl_grad (i,Jstr+1)
3672!^
3673 ad_grad(i,jstr+1)=ad_grad(i,jstr+1)+ad_grad(i,jstr)
3674 ad_grad(i,jstr)=0.0_r8
3675 END DO
3676 END IF
3677 END IF
3678
3679 DO j=jstrvm1,jendp1
3680 DO i=istr,iend
3681!^ tl_Dgrad(i,j)=tl_DVom(i,j-1)-2.0_r8*tl_DVom(i,j)+ &
3682!^ & tl_DVom(i,j+1)
3683!^
3684 ad_dvom(i,j-1)=ad_dvom(i,j-1)+ad_dgrad(i,j)
3685 ad_dvom(i,j )=ad_dvom(i,j )-2.0_r8*ad_dgrad(i,j)
3686 ad_dvom(i,j+1)=ad_dvom(i,j+1)+ad_dgrad(i,j)
3687 ad_dgrad(i,j)=0.0_r8
3688!^ tl_grad (i,j)=tl_vbar(i,j-1,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
3689# ifdef WEC_MELLOR
3690!^ & tl_vbar_stokes(i,j-1)- &
3691!^ & 2.0_r8*tl_vbar_stokes(i,j)+ &
3692!^ & tl_vbar_stokes(i,j+1)+ &
3693# endif
3694!^ & tl_vbar(i,j+1,krhs)
3695!^
3696 ad_vbar(i,j-1,krhs)=ad_vbar(i,j-1,krhs)+ad_grad(i,j)
3697 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)- &
3698 & 2.0_r8*ad_grad(i,j)
3699 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+ad_grad(i,j)
3700# ifdef WEC_MELLOR
3701 ad_vbar_stokes(i,j-1)=ad_vbar_stokes(i,j-1)+ad_grad(i,j)
3702 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )- &
3703 & 2.0_r8*ad_grad(i,j)
3704 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+ad_grad(i,j)
3705# endif
3706 ad_grad(i,j)=0.0_r8
3707 END DO
3708 END DO
3709 DO j=jstrv,jend
3710 DO i=istrm1,iendp1
3711 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ &
3712# ifdef WEC_MELLOR
3713 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
3714 & vbar_stokes(i+1,j)+ &
3715# endif
3716 & vbar(i+1,j,krhs)
3717 END DO
3718 END DO
3719 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3720 IF (domain(ng)%Western_Edge(tile)) THEN
3721 DO j=jstrv,jend
3722 grad(istr-1,j)=grad(istr,j)
3723 END DO
3724 END IF
3725 END IF
3726 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3727 IF (domain(ng)%Eastern_Edge(tile)) THEN
3728 DO j=jstrv,jend
3729 grad(iend+1,j)=grad(iend,j)
3730 END DO
3731 END IF
3732 END IF
3733 DO j=jstrv-1,jend
3734 DO i=istr,iend+1
3735 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
3736 END DO
3737 END DO
3738
3739 cff=1.0_r8/6.0_r8
3740 DO j=jstrv,jend
3741 DO i=istr,iend+1
3742!^ tl_VFx(i,j)=0.25_r8* &
3743!^ & ((tl_vbar(i ,j,krhs)+ &
3744# ifdef WEC_MELLOR
3745!^ & tl_vbar_stokes(i ,j)+ &
3746!^ & tl_vbar_stokes(i-1,j)+ &
3747# endif
3748!^ & tl_vbar(i-1,j,krhs)- &
3749!^ & cff*(tl_grad (i,j)+tl_grad (i-1,j)))* &
3750!^ & (DUon(i,j)+DUon(i,j-1)- &
3751!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))+ &
3752!^ & (vbar(i ,j,krhs)+ &
3753# ifdef WEC_MELLOR
3754!^ & vbar_stokes(i ,j)+ &
3755!^ & vbar_stokes(i-1,j)+ &
3756# endif
3757!^ & vbar(i-1,j,krhs)- &
3758!^ & cff*(grad (i,j)+grad (i-1,j)))* &
3759!^ & (tl_DUon(i,j)+tl_DUon(i,j-1)- &
3760!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j-1))))
3761!^
3762 adfac=0.25_r8*ad_vfx(i,j)
3763 adfac1=adfac*(duon(i,j)+duon(i,j-1)- &
3764 & cff*(dgrad(i,j)+dgrad(i,j-1)))
3765 adfac2=adfac1*cff
3766 adfac3=adfac*(vbar(i ,j,krhs)+ &
3767# ifdef WEC_MELLOR
3768 & vbar_stokes(i ,j)+ &
3769 & vbar_stokes(i-1,j)+ &
3770# endif
3771 & vbar(i-1,j,krhs)- &
3772 & cff*(grad(i,j)+grad(i-1,j)))
3773 adfac4=adfac3*cff
3774 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+adfac1
3775 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+adfac1
3776# ifdef WEC_MELLOR
3777 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac1
3778 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac1
3779# endif
3780 ad_grad(i-1,j)=ad_grad(i-1,j)-adfac2
3781 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
3782 ad_duon(i,j-1)=ad_duon(i,j-1)+adfac3
3783 ad_duon(i,j )=ad_duon(i,j )+adfac3
3784 ad_dgrad(i,j-1)=ad_dgrad(i,j-1)-adfac4
3785 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3786 ad_vfx(i,j)=0.0_r8
3787 END DO
3788 END DO
3789 DO j=jstrv-1,jend
3790 DO i=istr,iend+1
3791!^ tl_Dgrad(i,j)=tl_DUon(i,j-1)-2.0_r8*tl_DUon(i,j)+ &
3792!^ & tl_DUon(i,j+1)
3793!^
3794 ad_duon(i,j-1)=ad_duon(i,j-1)+ad_dgrad(i,j)
3795 ad_duon(i,j )=ad_duon(i,j )-2.0_r8*ad_dgrad(i,j)
3796 ad_duon(i,j+1)=ad_duon(i,j+1)+ad_dgrad(i,j)
3797 ad_dgrad(i,j)=0.0_r8
3798 END DO
3799 END DO
3800 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3801 IF (domain(ng)%Eastern_Edge(tile)) THEN
3802 DO j=jstrv,jend
3803!^ tl_grad(Iend+1,j)=tl_grad(Iend,j)
3804!^
3805 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
3806 ad_grad(iend+1,j)=0.0_r8
3807 END DO
3808 END IF
3809 END IF
3810 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3811 IF (domain(ng)%Western_Edge(tile)) THEN
3812 DO j=jstrv,jend
3813!^ tl_grad(Istr-1,j)=tl_grad(Istr,j)
3814!^
3815 ad_grad(istr,j)=ad_grad(istr,j)+ad_grad(istr-1,j)
3816 ad_grad(istr-1,j)=0.0_r8
3817 END DO
3818 END IF
3819 END IF
3820 DO j=jstrv,jend
3821 DO i=istrm1,iendp1
3822!^ tl_grad(i,j)=tl_vbar(i-1,j,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
3823# ifdef WEC_MELLOR
3824!^ & tl_vbar_stokes(i-1,j)- &
3825!^ & 2.0_r8*tl_vbar_stokes(i,j)+ &
3826!^ & tl_vbar_stokes(i+1,j)+ &
3827# endif
3828!^ & tl_vbar(i+1,j,krhs)
3829!^
3830 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+ad_grad(i,j)
3831 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)- &
3832 & 2.0_r8*ad_grad(i,j)
3833 ad_vbar(i+1,j,krhs)=ad_vbar(i+1,j,krhs)+ad_grad(i,j)
3834# ifdef WEC_MELLOR
3835 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+ad_grad(i,j)
3836 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)- &
3837 & 2.0_r8*ad_grad(i,j)
3838 ad_vbar_stokes(i+1,j)=ad_vbar_stokes(i+1,j)+ad_grad(i,j)
3839# endif
3840 ad_grad(i,j)=0.0_r8
3841 END DO
3842 END DO
3843 DO j=jstrm1,jendp1
3844 DO i=istru,iend
3845 grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ &
3846# ifdef WEC_MELLOR
3847 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
3848 & ubar_stokes(i,j+1)+ &
3849# endif
3850 & ubar(i,j+1,krhs)
3851 END DO
3852 END DO
3853 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3854 IF (domain(ng)%Southern_Edge(tile)) THEN
3855 DO i=istru,iend
3856 grad(i,jstr-1)=grad(i,jstr)
3857 END DO
3858 END IF
3859 END IF
3860 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3861 IF (domain(ng)%Northern_Edge(tile)) THEN
3862 DO i=istru,iend
3863 grad(i,jend+1)=grad(i,jend)
3864 END DO
3865 END IF
3866 END IF
3867 DO j=jstr,jend+1
3868 DO i=istru-1,iend
3869 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
3870 END DO
3871 END DO
3872
3873 cff=1.0_r8/6.0_r8
3874 DO j=jstr,jend+1
3875 DO i=istru,iend
3876!^ tl_UFe(i,j)=0.25_r8* &
3877!^ & ((tl_ubar(i,j ,krhs)+ &
3878# ifdef WEC_MELLOR
3879!^ & tl_ubar_stokes(i,j )+ &
3880!^ & tl_ubar_stokes(i,j-1)+ &
3881# endif
3882!^ & tl_ubar(i,j-1,krhs)- &
3883!^ & cff*(tl_grad (i,j)+tl_grad (i,j-1)))* &
3884!^ & (DVom(i,j)+DVom(i-1,j)- &
3885!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))+ &
3886!^ & (ubar(i,j ,krhs)+ &
3887# ifdef WEC_MELLOR
3888!^ & ubar_stokes(i,j )+ &
3889!^ & ubar_stokes(i,j-1)+ &
3890# endif
3891!^ & ubar(i,j-1,krhs)- &
3892!^ & cff*(grad (i,j)+grad (i,j-1)))* &
3893!^ & (tl_DVom(i,j)+tl_DVom(i-1,j)- &
3894!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i-1,j))))
3895!^
3896 adfac=0.25_r8*ad_ufe(i,j)
3897 adfac1=adfac*(dvom(i,j)+dvom(i-1,j)- &
3898 & cff*(dgrad(i,j)+dgrad(i-1,j)))
3899 adfac2=adfac1*cff
3900 adfac3=adfac*(ubar(i,j ,krhs)+ &
3901# ifdef WEC_MELLOR
3902 & ubar_stokes(i,j )+ &
3903 & ubar_stokes(i,j-1)+ &
3904# endif
3905 & ubar(i,j-1,krhs)- &
3906 & cff*(grad(i,j)+grad(i,j-1)))
3907 adfac4=adfac3*cff
3908 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+adfac1
3909 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+adfac1
3910# ifdef WEC_MELLOR
3911 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+adfac1
3912 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac1
3913# endif
3914 ad_grad(i,j-1)=ad_grad(i,j-1)-adfac2
3915 ad_grad(i,j )=ad_grad(i,j )-adfac2
3916 ad_dvom(i-1,j)=ad_dvom(i-1,j)+adfac3
3917 ad_dvom(i ,j)=ad_dvom(i ,j)+adfac3
3918 ad_dgrad(i-1,j)=ad_dgrad(i-1,j)-adfac4
3919 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
3920 ad_ufe(i,j)=0.0_r8
3921 END DO
3922 END DO
3923 DO j=jstr,jend+1
3924 DO i=istru-1,iend
3925!^ tl_Dgrad(i,j)=tl_DVom(i-1,j)-2.0_r8*tl_DVom(i,j)+ &
3926!^ & tl_DVom(i+1,j)
3927!^
3928 ad_dvom(i-1,j)=ad_dvom(i-1,j)+ad_dgrad(i,j)
3929 ad_dvom(i ,j)=ad_dvom(i ,j)-2.0_r8*ad_dgrad(i,j)
3930 ad_dvom(i+1,j)=ad_dvom(i+1,j)+ad_dgrad(i,j)
3931 ad_dgrad(i,j)=0.0_r8
3932 END DO
3933 END DO
3934 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3935 IF (domain(ng)%Northern_Edge(tile)) THEN
3936 DO i=istru,iend
3937!^ tl_grad(i,Jend+1)=tl_grad(i,Jend)
3938!^
3939 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3940 ad_grad(i,jend+1)=0.0_r8
3941 END DO
3942 END IF
3943 END IF
3944 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3945 IF (domain(ng)%Southern_Edge(tile)) THEN
3946 DO i=istru,iend
3947!^ tl_grad(i,Jstr-1)=tl_grad(i,Jstr)
3948!^
3949 ad_grad(i,jstr)=ad_grad(i,jstr)+ad_grad(i,jstr-1)
3950 ad_grad(i,jstr-1)=0.0_r8
3951 END DO
3952 END IF
3953 END IF
3954 DO j=jstrm1,jendp1
3955 DO i=istru,iend
3956!^ tl_grad(i,j)=tl_ubar(i,j-1,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
3957# ifdef WEC_MELLOR
3958!^ & tl_ubar_stokes(i,j-1)- &
3959!^ & 2.0_r8*tl_ubar_stokes(i,j)+ &
3960!^ & tl_ubar_stokes(i,j+1)+ &
3961# endif
3962!^ & tl_ubar(i,j+1,krhs)
3963!^
3964 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+ad_grad(i,j)
3965 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)- &
3966 & 2.0_r8*ad_grad(i,j)
3967 ad_ubar(i,j+1,krhs)=ad_ubar(i,j+1,krhs)+ad_grad(i,j)
3968# ifdef WEC_MELLOR
3969 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+ad_grad(i,j)
3970 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j)- &
3971 & 2.0_r8*ad_grad(i,j)
3972 ad_ubar_stokes(i,j+1)=ad_ubar_stokes(i,j+1)+ad_grad(i,j)
3973# endif
3974 ad_grad(i,j)=0.0_r8
3975 END DO
3976 END DO
3977 DO j=jstr,jend
3978 DO i=istrum1,iendp1
3979 grad(i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ &
3980# ifdef WEC_MELLOR
3981 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
3982 & ubar_stokes(i+1,j)+ &
3983# endif
3984 & ubar(i+1,j,krhs)
3985 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
3986 END DO
3987 END DO
3988 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3989 IF (domain(ng)%Western_Edge(tile)) THEN
3990 DO j=jstr,jend
3991 grad(istr,j)=grad(istr+1,j)
3992 dgrad(istr,j)=dgrad(istr+1,j)
3993 END DO
3994 END IF
3995 END IF
3996 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3997 IF (domain(ng)%Eastern_Edge(tile)) THEN
3998 DO j=jstr,jend
3999 grad(iend+1,j)=grad(iend,j)
4000 dgrad(iend+1,j)=dgrad(iend,j)
4001 END DO
4002 END IF
4003 END IF
4004
4005 cff=1.0_r8/6.0_r8
4006 DO j=jstr,jend
4007 DO i=istru-1,iend
4008!^ tl_UFx(i,j)=0.25_r8* &
4009!^ & ((ubar(i ,j,krhs)+ &
4010# ifdef WEC_MELLOR
4011!^ & ubar_stokes(i ,j)+ &
4012!^ & ubar_stokes(i+1,j)+ &
4013# endif
4014!^ & ubar(i+1,j,krhs)- &
4015!^ & cff*(grad (i,j)+grad (i+1,j)))* &
4016!^ & (tl_DUon(i,j)+tl_DUon(i+1,j)- &
4017!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i+1,j)))+ &
4018!^ & (tl_ubar(i ,j,krhs)+ &
4019# ifdef WEC_MELLOR
4020!^ & tl_ubar_stokes(i ,j)+ &
4021!^ & tl_ubar_stokes(i+1,j)+ &
4022# endif
4023!^ & tl_ubar(i+1,j,krhs)- &
4024!^ & cff*(tl_grad (i,j)+tl_grad (i+1,j)))* &
4025!^ & (DUon(i,j)+DUon(i+1,j)- &
4026!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j))))
4027!^
4028 adfac=0.25_r8*ad_ufx(i,j)
4029 adfac1=adfac*(duon(i,j)+duon(i+1,j)- &
4030 & cff*(dgrad(i,j)+dgrad(i+1,j)))
4031 adfac2=adfac1*cff
4032 adfac3=adfac*(ubar(i ,j,krhs)+ &
4033# ifdef WEC_MELLOR
4034 & ubar_stokes(i ,j)+ &
4035 & ubar_stokes(i+1,j)+ &
4036# endif
4037 & ubar(i+1,j,krhs)- &
4038 & cff*(grad(i,j)+grad(i+1,j)))
4039 adfac4=adfac3*cff
4040 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac1
4041 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac1
4042# ifdef WEC_MELLOR
4043 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac1
4044 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac1
4045# endif
4046 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
4047 ad_grad(i+1,j)=ad_grad(i+1,j)-adfac2
4048 ad_duon(i ,j)=ad_duon(i ,j)+adfac3
4049 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac3
4050 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
4051 ad_dgrad(i+1,j)=ad_dgrad(i+1,j)-adfac4
4052 ad_ufx(i,j)=0.0_r8
4053 END DO
4054 END DO
4055 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
4056 IF (domain(ng)%Eastern_Edge(tile)) THEN
4057 DO j=jstr,jend
4058!^ tl_Dgrad(Iend+1,j)=tl_Dgrad(Iend,j)
4059!^
4060 ad_dgrad(iend,j)=ad_dgrad(iend,j)+ad_dgrad(iend+1,j)
4061 ad_dgrad(iend+1,j)=0.0_r8
4062!^ tl_grad (Iend+1,j)=tl_grad (Iend,j)
4063!^
4064 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
4065 ad_grad(iend+1,j)=0.0_r8
4066 END DO
4067 END IF
4068 END IF
4069 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
4070 IF (domain(ng)%Western_Edge(tile)) THEN
4071 DO j=jstr,jend
4072!^ tl_Dgrad(Istr,j)=tl_Dgrad(Istr+1,j)
4073!^
4074 ad_dgrad(istr+1,j)=ad_dgrad(istr+1,j)+ad_dgrad(istr,j)
4075 ad_dgrad(istr,j)=0.0_r8
4076!^ tl_grad (Istr,j)=tl_grad (Istr+1,j)
4077!^
4078 ad_grad(istr+1,j)=ad_grad(istr+1,j)+ad_grad(istr,j)
4079 ad_grad(istr,j)=0.0_r8
4080 END DO
4081 END IF
4082 END IF
4083 DO j=jstr,jend
4084 DO i=istrum1,iendp1
4085!^ tl_Dgrad(i,j)=tl_DUon(i-1,j)-2.0_r8*tl_DUon(i,j)+ &
4086!^ & tl_DUon(i+1,j)
4087!^
4088 ad_duon(i-1,j)=ad_duon(i-1,j)+ad_dgrad(i,j)
4089 ad_duon(i ,j)=ad_duon(i ,j)-2.0_r8*ad_dgrad(i,j)
4090 ad_duon(i+1,j)=ad_duon(i+1,j)+ad_dgrad(i,j)
4091 ad_dgrad(i,j)=0.0_r8
4092!^ tl_grad (i,j)=tl_ubar(i-1,j,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
4093# ifdef NEARHSORE_MELLOR
4094!^ & tl_ubar_stokes(i-1,j)- &
4095!^ & 2.0_r8*tl_ubar_stokes(i,j)+ &
4096!^ & tl_ubar_stokes(i+1,j)+ &
4097# endif
4098!^ & tl_ubar(i+1,j,krhs)
4099!^
4100 ad_ubar(i-1,j,krhs)=ad_ubar(i-1,j,krhs)+ad_grad(i,j)
4101 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)- &
4102 & 2.0_r8*ad_grad(i,j)
4103 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+ad_grad(i,j)
4104# ifdef NEARHSORE_MELLOR
4105 ad_ubar_stokes(i-1,j)=ad_ubar_stokes(i-1,j)+ad_grad(i,j)
4106 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)- &
4107 & 2.0_r8*ad_grad(i,j)
4108 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+ad_grad(i,j)
4109# endif
4110 ad_grad(i,j)=0.0_r8
4111 END DO
4112 END DO
4113# endif
4114#endif
4115!
4116!-----------------------------------------------------------------------
4117! Compute adjoint pressure gradient terms.
4118!-----------------------------------------------------------------------
4119!
4120! Compute BASIC STATE fields associated with pressure gradient and
4121! time-stepping of adjoint free-surface.
4122!
4123 fac=1000.0_r8/rho0
4124 IF (first_2d_step) THEN
4125 cff1=dtfast(ng)
4126 DO j=jstrv-1,jend
4127 DO i=istru-1,iend
4128!^ rhs_zeta(i,j)=(DUon(i,j)-DUon(i+1,j))+ &
4129!^ & (DVom(i,j)-DVom(i,j+1))
4130!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
4131!^ & pm(i,j)*pn(i,j)*cff1*rhs_zeta(i,j)
4132!^
4133!^ use background instead
4134 zeta_new(i,j)=zeta(i,j,knew)
4135#ifdef MASKING
4136 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
4137#endif
4138 zwrk(i,j)=0.5_r8*(zeta(i,j,kstp)+zeta_new(i,j))
4139#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4140 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
4141 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
4142 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
4143#else
4144 gzeta(i,j)=zwrk(i,j)
4145 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
4146#endif
4147 END DO
4148 END DO
4149 ELSE IF (predictor_2d_step(ng)) THEN
4150 cff1=2.0_r8*dtfast(ng)
4151 cff4=4.0_r8/25.0_r8
4152 cff5=1.0_r8-2.0_r8*cff4
4153 DO j=jstrv-1,jend
4154 DO i=istru-1,iend
4155!^ rhs_zeta(i,j)=(DUon(i,j)-DUon(i+1,j))+ &
4156!^ & (DVom(i,j)-DVom(i,j+1))
4157!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
4158!^ & pm(i,j)*pn(i,j)*cff1*rhs_zeta(i,j)
4159!^
4160!^ use background instead
4161 zeta_new(i,j)=zeta(i,j,knew)
4162#ifdef MASKING
4163 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
4164#endif
4165 zwrk(i,j)=cff5*zeta(i,j,krhs)+ &
4166 & cff4*(zeta(i,j,kstp)+zeta_new(i,j))
4167#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4168 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
4169 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
4170 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
4171#else
4172 gzeta(i,j)=zwrk(i,j)
4173 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
4174#endif
4175 END DO
4176 END DO
4177 ELSE IF (corrector_2d_step) THEN
4178 cff1=dtfast(ng)*5.0_r8/12.0_r8
4179 cff2=dtfast(ng)*8.0_r8/12.0_r8
4180 cff3=dtfast(ng)*1.0_r8/12.0_r8
4181 cff4=2.0_r8/5.0_r8
4182 cff5=1.0_r8-cff4
4183 DO j=jstrv-1,jend
4184 DO i=istru-1,iend
4185!^ cff=cff1*((DUon(i,j)-DUon(i+1,j))+ &
4186!^ & (DVom(i,j)-DVom(i,j+1)))
4187!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
4188!^ & pm(i,j)*pn(i,j)*(cff+ &
4189!^ & cff2*rzeta(i,j,kstp)- &
4190!^ & cff3*rzeta(i,j,ptsk))
4191!^
4192!^ use background instead
4193 zeta_new(i,j)=zeta(i,j,knew)
4194#ifdef MASKING
4195 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
4196#endif
4197 zwrk(i,j)=cff5*zeta_new(i,j)+cff4*zeta(i,j,krhs)
4198#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4199 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
4200 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
4201 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
4202#else
4203 gzeta(i,j)=zwrk(i,j)
4204 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
4205#endif
4206 END DO
4207 END DO
4208 END IF
4209!
4210! Compute adjoint pressure gradient.
4211!
4212 cff1=0.5_r8*g
4213 cff2=1.0_r8/3.0_r8
4214#if !defined SOLVE3D && defined ATM_PRESS
4215 fac3=0.5_r8*100.0_r8/rho0
4216#endif
4217 DO j=jstr,jend
4218 IF (j.ge.jstrv) THEN
4219 DO i=istr,iend
4220#ifdef DIAGNOSTICS_UV
4221!! DiaV2rhs(i,j,M2pgrd)=rhs_vbar(i,j)
4222#endif
4223#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
4224!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)- &
4225!^ & cff1*om_v(i,j)* &
4226!^ & ((tl_h(i,j-1)+tl_h(i,j)+ &
4227!^ & tl_gzeta(i,j-1)+tl_gzeta(i,j))* &
4228!^ & (eq_tide(i,j)-eq_tide(i,j-1))+ &
4229!^ & (h(i,j-1)+h(i,j)+ &
4230!^ & gzeta(i,j-1)+gzeta(i,j))* &
4231!^ & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
4232!^
4233 adfac=cff1*om_v(i,j)*ad_rhs_vbar(i,j)
4234 adfac1=adfac*(eq_tide(i,j)-eq_tide(i,j-1))
4235 adfac2=adfac*(h(i,j-1)+h(i,j)+ &
4236 & gzeta(i,j-1)+gzeta(i,j))
4237 ad_h(i,j-1)=ad_h(i,j-1)-adfac1
4238 ad_h(i,j )=ad_h(i,j )-adfac1
4239 ad_gzeta(i,j-1)=ad_gzeta(i,j-1)-adfac1
4240 ad_gzeta(i,j )=ad_gzeta(i,j )-adfac1
4241 ad_eq_tide(i,j-1)=ad_eq_tide(i,j-1)+adfac2
4242 ad_eq_tide(i,j )=ad_eq_tide(i,j )-adfac2
4243#endif
4244#if defined ATM_PRESS && !defined SOLVE3D
4245!^ tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)- &
4246!^ & fac3*om_v(i,j)* &
4247!^ & (tl_h(i,j-1)+tl_h(i,j)+ &
4248!^ & tl_gzeta(i,j-1)+tl_gzeta(i,j))* &
4249!^ & (Pair(i,j)-Pair(i,j-1))
4250!^
4251 adfac=-fac3*om_v(i,j)*(pair(i,j)-pair(i,j-1)* &
4252 & ad_rhs_vbar(i,j)
4253 ad_h(i,j-1)=ad_h(i,j-1)+adfac
4254 ad_h(i,j )=ad_h(i,j )+adfac
4255 ad_gzeta(i,j-1)=ad_gzeta(i,j-1)+adfac
4256 ad_gzeta(i,j )=ad_gzeta(i,j )+adfac
4257#endif
4258!^ tl_rhs_vbar(i,j)=cff1*om_v(i,j)* &
4259!^ & ((tl_h(i,j-1)+ &
4260!^ & tl_h(i,j ))* &
4261!^ & (gzeta(i,j-1)- &
4262!^ & gzeta(i,j ))+ &
4263!^ & (h(i,j-1)+ &
4264!^ & h(i,j ))* &
4265!^ & (tl_gzeta(i,j-1)- &
4266!^ & tl_gzeta(i,j ))+ &
4267#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4268!^ & (tl_h(i,j-1)- &
4269!^ & tl_h(i,j ))* &
4270!^ & (gzetaSA(i,j-1)+ &
4271!^ & gzetaSA(i,j )+ &
4272!^ & cff2*(rhoA(i,j-1)- &
4273!^ & rhoA(i,j ))* &
4274!^ & (zwrk(i,j-1)- &
4275!^ & zwrk(i,j )))+ &
4276!^ & (h(i,j-1)- &
4277!^ & h(i,j ))* &
4278!^ & (tl_gzetaSA(i,j-1)+ &
4279!^ & tl_gzetaSA(i,j )+ &
4280!^ & cff2*((tl_rhoA(i,j-1)- &
4281!^ & tl_rhoA(i,j ))* &
4282!^ & (zwrk(i,j-1)- &
4283!^ & zwrk(i,j ))+ &
4284!^ & (rhoA(i,j-1)- &
4285!^ & rhoA(i,j ))* &
4286!^ & (tl_zwrk(i,j-1)- &
4287!^ & tl_zwrk(i,j ))))+ &
4288#endif
4289!^ & (tl_gzeta2(i,j-1)- &
4290!^ & tl_gzeta2(i,j )
4291!^
4292 adfac=cff1*om_v(i,j)*ad_rhs_vbar(i,j)
4293 adfac1=adfac*(gzeta(i,j-1)-gzeta(i,j ))
4294 adfac2=adfac*(h(i,j-1)+h(i,j ))
4295 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
4296 ad_h(i,j )=ad_h(i,j )+adfac1
4297 ad_gzeta(i,j-1)=ad_gzeta(i,j-1)+adfac2
4298 ad_gzeta(i,j )=ad_gzeta(i,j )-adfac2
4299 ad_gzeta2(i,j-1)=ad_gzeta2(i,j-1)+adfac
4300 ad_gzeta2(i,j )=ad_gzeta2(i,j )-adfac
4301#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4302 adfac1=adfac*(gzetasa(i,j-1)+ &
4303 & gzetasa(i,j )+ &
4304 & cff2*(rhoa(i,j-1)- &
4305 & rhoa(i,j ))* &
4306 & (zwrk(i,j-1)- &
4307 & zwrk(i,j )))
4308 adfac2=adfac*(h(i,j-1)-h(i,j))
4309 adfac3=adfac2*cff2*(zwrk(i,j-1)-zwrk(i,j))
4310 adfac4=adfac2*cff2*(rhoa(i,j-1)-rhoa(i,j))
4311 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
4312 ad_h(i,j )=ad_h(i,j )-adfac1
4313 ad_gzetasa(i,j-1)=ad_gzetasa(i,j-1)+adfac2
4314 ad_gzetasa(i,j )=ad_gzetasa(i,j )+adfac2
4315 ad_rhoa(i,j-1)=ad_rhoa(i,j-1)+adfac3
4316 ad_rhoa(i,j )=ad_rhoa(i,j )-adfac3
4317 ad_zwrk(i,j-1)=ad_zwrk(i,j-1)+adfac4
4318 ad_zwrk(i,j )=ad_zwrk(i,j )-adfac4
4319#endif
4320 ad_rhs_vbar(i,j)=0.0_r8
4321 END DO
4322 END IF
4323 DO i=istru,iend
4324#ifdef DIAGNOSTICS_UV
4325!! DiaU2rhs(i,j,M2pgrd)=rhs_ubar(i,j)
4326#endif
4327#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
4328!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)- &
4329!^ & cff1*on_u(i,j)* &
4330!^ & ((tl_h(i-1,j)+tl_h(i,j)+ &
4331!^ & tl_gzeta(i-1,j)+tl_gzeta(i,j))* &
4332!^ & (eq_tide(i,j)-eq_tide(i-1,j))+ &
4333!^ & (h(i-1,j)+h(i,j)+ &
4334!^ & gzeta(i-1,j)+gzeta(i,j))* &
4335!^ & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
4336!^
4337 adfac=cff1*on_u(i,j)*ad_rhs_ubar(i,j)
4338 adfac1=adfac*(eq_tide(i,j)-eq_tide(i-1,j))
4339 adfac2=adfac*(h(i-1,j)+h(i,j)+ &
4340 & gzeta(i-1,j)+gzeta(i,j))
4341 ad_h(i-1,j)=ad_h(i-1,j)-adfac1
4342 ad_h(i ,j)=ad_h(i ,j)-adfac1
4343 ad_gzeta(i-1,j)=ad_gzeta(i-1,j)-adfac1
4344 ad_gzeta(i ,j)=ad_gzeta(i ,j)-adfac1
4345 ad_eq_tide(i-1,j)=ad_eq_tide(i-1,j)+adfac2
4346 ad_eq_tide(i ,j)=ad_eq_tide(i ,j)-adfac2
4347#endif
4348#if defined ATM_PRESS && !defined SOLVE3D
4349!^ tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)- &
4350!^ & fac3*on_u(i,j)* &
4351!^ & (tl_h(i-1,j)+tl_h(i,j)+ &
4352!^ & tl_gzeta(i-1,j)+tl_gzeta(i,j))* &
4353!^ & (Pair(i,j)-Pair(i-1,j))
4354!^
4355 adfac=-fac3*on_u(i,j)*(pair(i,j)-pair(i-1,j))* &
4356 & ad_rhs_ubar(i,j)
4357 ad_h(i-1,j)=ad_h(i-1,j)+adfac
4358 ad_h(i ,j)=ad_h(i ,j)+adfac
4359 ad_gzeta(i-1,j)=ad_gzeta(i-1,j)+adfac
4360 ad_gzeta(i ,j)=ad_gzeta(i ,j)+adfac
4361#endif
4362!^ tl_rhs_ubar(i,j)=cff1*on_u(i,j)* &
4363!^ & ((tl_h(i-1,j)+ &
4364!^ & tl_h(i ,j))* &
4365!^ & (gzeta(i-1,j)- &
4366!^ & gzeta(i ,j))+ &
4367!^ & (h(i-1,j)+ &
4368!^ & h(i ,j))* &
4369!^ & (tl_gzeta(i-1,j)- &
4370!^ & tl_gzeta(i ,j))+ &
4371#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4372!^ & (tl_h(i-1,j)- &
4373!^ & tl_h(i ,j))* &
4374!^ & (gzetaSA(i-1,j)+ &
4375!^ & gzetaSA(i ,j)+ &
4376!^ & cff2*(rhoA(i-1,j)- &
4377!^ & rhoA(i ,j))* &
4378!^ & (zwrk(i-1,j)- &
4379!^ & zwrk(i ,j)))+ &
4380!^ & (h(i-1,j)- &
4381!^ & h(i ,j))* &
4382!^ & (tl_gzetaSA(i-1,j)+ &
4383!^ & tl_gzetaSA(i ,j)+ &
4384!^ & cff2*((tl_rhoA(i-1,j)- &
4385!^ & tl_rhoA(i ,j))* &
4386!^ & (zwrk(i-1,j)- &
4387!^ & zwrk(i ,j))+ &
4388!^ & (rhoA(i-1,j)- &
4389!^ & rhoA(i ,j))* &
4390!^ & (tl_zwrk(i-1,j)- &
4391!^ & tl_zwrk(i ,j))))+ &
4392#endif
4393!^ & (tl_gzeta2(i-1,j)- &
4394!^ & tl_gzeta2(i ,j)))
4395!^
4396 adfac=cff1*on_u(i,j)*ad_rhs_ubar(i,j)
4397 adfac1=adfac*(gzeta(i-1,j)-gzeta(i ,j))
4398 adfac2=adfac*(h(i-1,j)+h(i ,j))
4399 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
4400 ad_h(i ,j)=ad_h(i ,j)+adfac1
4401 ad_gzeta(i-1,j)=ad_gzeta(i-1,j)+adfac2
4402 ad_gzeta(i ,j)=ad_gzeta(i ,j)-adfac2
4403 ad_gzeta2(i-1,j)=ad_gzeta2(i-1,j)+adfac
4404 ad_gzeta2(i ,j)=ad_gzeta2(i ,j)-adfac
4405#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4406 adfac1=adfac*(gzetasa(i-1,j)+ &
4407 & gzetasa(i ,j)+ &
4408 & cff2*(rhoa(i-1,j)- &
4409 & rhoa(i ,j))* &
4410 & (zwrk(i-1,j)- &
4411 & zwrk(i ,j)))
4412 adfac2=adfac*(h(i-1,j)-h(i ,j))
4413 adfac3=adfac2*cff2*(zwrk(i-1,j)-zwrk(i,j))
4414 adfac4=adfac2*cff2*(rhoa(i-1,j)-rhoa(i,j))
4415 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
4416 ad_h(i ,j)=ad_h(i ,j)-adfac1
4417 ad_gzetasa(i-1,j)=ad_gzetasa(i-1,j)+adfac2
4418 ad_gzetasa(i ,j)=ad_gzetasa(i ,j)+adfac2
4419 ad_rhoa(i-1,j)=ad_rhoa(i-1,j)+adfac3
4420 ad_rhoa(i ,j)=ad_rhoa(i ,j)-adfac3
4421 ad_zwrk(i-1,j)=ad_zwrk(i-1,j)+adfac4
4422 ad_zwrk(i ,j)=ad_zwrk(i ,j)-adfac4
4423#endif
4424 ad_rhs_ubar(i,j)=0.0_r8
4425 END DO
4426 END DO
4427!
4428! Set adjoint free-surface lateral boundary conditions.
4429!
4430#ifdef DISTRIBUTE
4431!^ CALL mp_exchange2d (ng, tile, iTLM, 1, &
4432!^ & LBi, UBi, LBj, UBj, &
4433!^ & NghostPoints, &
4434!^ & EWperiodic(ng), NSperiodic(ng), &
4435!^ & tl_zeta(:,:,knew))
4436!^
4437 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
4438 & lbi, ubi, lbj, ubj, &
4439 & nghostpoints, &
4440 & ewperiodic(ng), nsperiodic(ng), &
4441 & ad_zeta(:,:,knew))
4442#endif
4443 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
4444!^ CALL exchange_r2d_tile (ng, tile, &
4445!^ & LBi, UBi, LBj, UBj, &
4446!^ & tl_zeta(:,:,knew))
4447!^
4448 CALL ad_exchange_r2d_tile (ng, tile, &
4449 & lbi, ubi, lbj, ubj, &
4450 & ad_zeta(:,:,knew))
4451 END IF
4452!^ CALL tl_zetabc_tile (ng, tile, &
4453!^ & LBi, UBi, LBj, UBj, &
4454!^ & IminS, ImaxS, JminS, JmaxS, &
4455!^ & krhs, kstp, knew, &
4456!^ & zeta, tl_zeta)
4457!^
4458 CALL ad_zetabc_tile (ng, tile, &
4459 & lbi, ubi, lbj, ubj, &
4460 & imins, imaxs, jmins, jmaxs, &
4461 & krhs, kstp, knew, &
4462 & zeta, ad_zeta)
4463
4464#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
4465!
4466! Scale the bed change with the fast time stepping. The half is
4467! becasue we do predictor and corrector. The "ndtfast/nfast" is
4468! becasue we do "nfast" steps to here.
4469!
4470 fac=0.5_r8*dtfast(ng)*ndtfast(ng)/(nfast(ng)*dt(ng))
4471 DO j=jstr,jend
4472 DO i=istr,iend
4473!^ tl_h(i,j)=tl_h(i,j)-tl_cff
4474!^
4475 ad_cff=ad_cff-ad_h(i,j)
4476!^ tl_cff=fac*(tl_bed_thick(i,j,nstp)-tl_bed_thick(i,j,nnew))
4477!^
4478 adfac=fac*ad_cff
4479 ad_bed_thick(i,j,nnew)=ad_bed_thick(i,j,nnew)-adfac
4480 ad_bed_thick(i,j,nstp)=ad_bed_thick(i,j,nstp)+adfac
4481 ad_cff=0.0_r8
4482 END DO
4483 END DO
4484#endif
4485!
4486! Apply adjoint mass point sources (volume vertical influx), if any.
4487!
4488! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
4489!
4490 IF (lwsrc(ng)) THEN
4491 DO is=1,nsrc(ng)
4492 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
4493 i=sources(ng)%Isrc(is)
4494 j=sources(ng)%Jsrc(is)
4495 IF (((istrr.le.i).and.(i.le.iendr)).and. &
4496 & ((jstrr.le.j).and.(j.le.jendr))) THEN
4497!^ tl_zeta(i,j,knew)=tl_zeta(i,j,knew)+0.0_r8
4498!^
4499 END IF
4500 END IF
4501 END DO
4502 END IF
4503!
4504! If adjoint predictor step, load right-side-term into shared array.
4505!
4506 IF (predictor_2d_step(ng)) THEN
4507#ifdef DISTRIBUTE
4508!^ CALL mp_exchange2d (ng, tile, iTLM, 1, &
4509!^ & LBi, UBi, LBj, UBj, &
4510!^ & NghostPoints, &
4511!^ & EWperiodic(ng), NSperiodic(ng), &
4512!^ & tl_rzeta(:,:,krhs))
4513!^
4514 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
4515 & lbi, ubi, lbj, ubj, &
4516 & nghostpoints, &
4517 & ewperiodic(ng), nsperiodic(ng), &
4518 & ad_rzeta(:,:,krhs))
4519#endif
4520 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
4521!^ CALL exchange_r2d_tile (ng, tile, &
4522!^ & LBi, UBi, LBj, UBj, &
4523!^ & tl_rzeta(:,:,krhs))
4524!^
4525 CALL ad_exchange_r2d_tile (ng, tile, &
4526 & lbi, ubi, lbj, ubj, &
4527 & ad_rzeta(:,:,krhs))
4528 END IF
4529 DO j=jstr,jend
4530 DO i=istr,iend
4531!^ tl_rzeta(i,j,krhs)=tl_rhs_zeta(i,j)
4532!^
4533 ad_rhs_zeta(i,j)=ad_rhs_zeta(i,j)+ad_rzeta(i,j,krhs)
4534 ad_rzeta(i,j,krhs)=0.0
4535 END DO
4536 END DO
4537 END IF
4538
4539#ifndef SOLVE3D
4540!
4541! Save free-surface adjoint solution for IO purposes.
4542!
4543 DO j=jstrr,jendr
4544 DO i=istrr,iendr
4545 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
4546 END DO
4547 END DO
4548#endif
4549!
4550! Load new adjoint free-surface values into shared array at both
4551! predictor and corrector steps.
4552#ifdef WET_DRY_NOT_YET
4553! Modify new free-surface to Ensure that depth is > Dcrit for masked
4554! cells.
4555#endif
4556!
4557 DO j=jstr,jend
4558 DO i=istr,iend
4559#if defined WET_DRY_NOT_YET && defined MASKING
4560!^ tl_zeta(i,j,knew)=tl_zeta(i,j,knew)- &
4561!^ & tl_h(i,j)*(1.0_r8-rmask(i,j))
4562!^
4563 ad_h(i,j)=ad_h(i,j)+(1.0_r8-rmask(i,j))*ad_zeta(i,j,knew)
4564#endif
4565!^ tl_zeta(i,j,knew)=tl_zeta_new(i,j)
4566!^
4567 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_zeta(i,j,knew)
4568 ad_zeta(i,j,knew)=0.0_r8
4569 END DO
4570 END DO
4571!
4572!=======================================================================
4573! Time step adjoint free-surface equation.
4574!=======================================================================
4575!
4576! During the first time-step, the predictor step is Forward-Euler
4577! and the corrector step is Backward-Euler. Otherwise, the predictor
4578! step is Leap-frog and the corrector step is Adams-Moulton.
4579!
4580#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4581 fac=1000.0_r8/rho0
4582#endif
4583 IF (first_2d_step) THEN
4584 cff1=dtfast(ng)
4585 DO j=jstrv-1,jend
4586 DO i=istru-1,iend
4587#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4588!^ tl_gzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4589!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4590!^
4591 adfac=zwrk(i,j)*ad_gzetasa(i,j)
4592 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4593 & (rhos(i,j)-rhoa(i,j))*ad_gzetasa(i,j)
4594 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4595 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4596 ad_gzetasa(i,j)=0.0_r8
4597!^ tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
4598!^ & gzeta(i,j)*tl_zwrk(i,j)
4599!^
4600 ad_gzeta(i,j)=ad_gzeta(i,j)+zwrk(i,j)*ad_gzeta2(i,j)
4601 ad_zwrk(i,j)=ad_zwrk(i,j)+gzeta(i,j)*ad_gzeta2(i,j)
4602 ad_gzeta2(i,j)=0.0_r8
4603!^ tl_gzeta(i,j)=(fac+rhoS(i,j))*tl_zwrk(i,j)+ &
4604!^ & tl_rhoS(i,j)*zwrk(i,j)
4605!^
4606 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_gzeta(i,j)
4607 ad_zwrk(i,j)=ad_zwrk(i,j)+(fac+rhos(i,j))*ad_gzeta(i,j)
4608 ad_gzeta(i,j)=0.0_r8
4609#else
4610!^ tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4611!^ tl_gzeta(i,j)=tl_zwrk(i,j)
4612!^
4613 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4614 & 2.0_r8*zwrk(i,j)*ad_gzeta2(i,j)+ &
4615 & ad_gzeta(i,j)
4616 ad_gzeta2(i,j)=0.0_r8
4617 ad_gzeta(i,j)=0.0_r8
4618#endif
4619!^ tl_zwrk(i,j)=0.5_r8*(tl_zeta(i,j,kstp)+tl_zeta_new(i,j))
4620!^
4621 adfac=0.5_r8*ad_zwrk(i,j)
4622 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+adfac
4623 ad_zeta_new(i,j)=ad_zeta_new(i,j)+adfac
4624 ad_zwrk(i,j)=0.0_r8
4625!^ tl_Dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
4626!^
4627 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_dnew(i,j)
4628 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
4629 ad_dnew(i,j)=0.0_r8
4630#ifdef MASKING
4631!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4632!^
4633 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4634#endif
4635!^ tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
4636!^ & pm(i,j)*pn(i,j)*cff1*tl_rhs_zeta(i,j)
4637!^
4638 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_zeta_new(i,j)
4639 ad_rhs_zeta(i,j)=ad_rhs_zeta(i,j)+ &
4640 & pm(i,j)*pn(i,j)*cff1*ad_zeta_new(i,j)
4641 ad_zeta_new(i,j)=0.0_r8
4642!^ tl_rhs_zeta(i,j)=(tl_DUon(i,j)-tl_DUon(i+1,j))+ &
4643!^ & (tl_DVom(i,j)-tl_DVom(i,j+1))
4644!^
4645 ad_duon(i ,j )=ad_duon(i ,j )+ad_rhs_zeta(i,j)
4646 ad_duon(i+1,j )=ad_duon(i+1,j )-ad_rhs_zeta(i,j)
4647 ad_dvom(i ,j )=ad_dvom(i ,j )+ad_rhs_zeta(i,j)
4648 ad_dvom(i ,j+1)=ad_dvom(i ,j+1)-ad_rhs_zeta(i,j)
4649 ad_rhs_zeta(i,j)=0.0_r8
4650 END DO
4651 END DO
4652 ELSE IF (predictor_2d_step(ng)) THEN
4653 cff1=2.0_r8*dtfast(ng)
4654 cff4=4.0_r8/25.0_r8
4655 cff5=1.0_r8-2.0_r8*cff4
4656 DO j=jstrv-1,jend
4657 DO i=istru-1,iend
4658#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4659!^ tl_gzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4660!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4661!^
4662 adfac=zwrk(i,j)*ad_gzetasa(i,j)
4663 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4664 & (rhos(i,j)-rhoa(i,j))*ad_gzetasa(i,j)
4665 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4666 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4667 ad_gzetasa(i,j)=0.0_r8
4668!^ tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
4669!^ & gzeta(i,j)*tl_zwrk(i,j)
4670!^
4671 ad_gzeta(i,j)=ad_gzeta(i,j)+zwrk(i,j)*ad_gzeta2(i,j)
4672 ad_zwrk(i,j)=ad_zwrk(i,j)+gzeta(i,j)*ad_gzeta2(i,j)
4673 ad_gzeta2(i,j)=0.0_r8
4674!^ tl_gzeta(i,j)=(fac+rhoS(i,j))*tl_zwrk(i,j)+ &
4675!^ & tl_rhoS(i,j)*zwrk(i,j)
4676!^
4677 ad_zwrk(i,j)=ad_zwrk(i,j)+(fac+rhos(i,j))*ad_gzeta(i,j)
4678 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_gzeta(i,j)
4679 ad_gzeta(i,j)=0.0_r8
4680#else
4681!^ tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4682!^ tl_gzeta(i,j)=tl_zwrk(i,j)
4683!^
4684 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4685 & 2.0_r8*zwrk(i,j)*ad_gzeta2(i,j)+ &
4686 & ad_gzeta(i,j)
4687 ad_gzeta2(i,j)=0.0_r8
4688 ad_gzeta(i,j)=0.0_r8
4689#endif
4690!^ tl_zwrk(i,j)=cff5*tl_zeta(i,j,krhs)+ &
4691!^ & cff4*(tl_zeta(i,j,kstp)+tl_zeta_new(i,j))
4692!^
4693 adfac=cff4*ad_zwrk(i,j)
4694 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+cff5*ad_zwrk(i,j)
4695 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+adfac
4696 ad_zeta_new(i,j)=ad_zeta_new(i,j)+adfac
4697 ad_zwrk(i,j)=0.0_r8
4698!^ tl_Dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
4699!^
4700 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_dnew(i,j)
4701 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
4702 ad_dnew(i,j)=0.0_r8
4703#ifdef MASKING
4704!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4705!^
4706 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4707#endif
4708!^ tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
4709!^ & pm(i,j)*pn(i,j)*cff1*tl_rhs_zeta(i,j)
4710!^
4711 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_zeta_new(i,j)
4712 ad_rhs_zeta(i,j)=ad_rhs_zeta(i,j)+ &
4713 & pm(i,j)*pn(i,j)*cff1*ad_zeta_new(i,j)
4714 ad_zeta_new(i,j)=0.0_r8
4715!^ tl_rhs_zeta(i,j)=(tl_DUon(i,j)-tl_DUon(i+1,j))+ &
4716!^ & (tl_DVom(i,j)-tl_DVom(i,j+1))
4717!^
4718 ad_duon(i ,j )=ad_duon(i ,j )+ad_rhs_zeta(i,j)
4719 ad_duon(i+1,j )=ad_duon(i+1,j )-ad_rhs_zeta(i,j)
4720 ad_dvom(i ,j )=ad_dvom(i ,j )+ad_rhs_zeta(i,j)
4721 ad_dvom(i ,j+1)=ad_dvom(i ,j+1)-ad_rhs_zeta(i,j)
4722 ad_rhs_zeta(i,j)=0.0_r8
4723 END DO
4724 END DO
4725 ELSE IF (corrector_2d_step) THEN
4726 cff1=dtfast(ng)*5.0_r8/12.0_r8
4727 cff2=dtfast(ng)*8.0_r8/12.0_r8
4728 cff3=dtfast(ng)*1.0_r8/12.0_r8
4729 cff4=2.0_r8/5.0_r8
4730 cff5=1.0_r8-cff4
4731 DO j=jstrv-1,jend
4732 DO i=istru-1,iend
4733#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
4734!^ tl_gzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4735!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4736!^
4737 adfac=zwrk(i,j)*ad_gzetasa(i,j)
4738 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4739 & (rhos(i,j)-rhoa(i,j))*ad_gzetasa(i,j)
4740 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4741 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4742 ad_gzetasa(i,j)=0.0_r8
4743!^ tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
4744!^ & gzeta(i,j)*tl_zwrk(i,j)
4745!^
4746 ad_zwrk(i,j)=ad_zwrk(i,j)+gzeta(i,j)*ad_gzeta2(i,j)
4747 ad_gzeta(i,j)=ad_gzeta(i,j)+zwrk(i,j)*ad_gzeta2(i,j)
4748 ad_gzeta2(i,j)=0.0_r8
4749!^ tl_gzeta(i,j)=(fac+rhoS(i,j))*tl_zwrk(i,j)+ &
4750!^ & tl_rhoS(i,j)*zwrk(i,j)
4751!^
4752 ad_zwrk(i,j)=ad_zwrk(i,j)+(fac+rhos(i,j))*ad_gzeta(i,j)
4753 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_gzeta(i,j)
4754 ad_gzeta(i,j)=0.0_r8
4755#else
4756!^ tl_gzeta(i,j)=tl_zwrk(i,j)
4757!^ tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4758!^
4759 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4760 & 2.0_r8*zwrk(i,j)*ad_gzeta2(i,j)+ &
4761 & ad_gzeta(i,j)
4762 ad_gzeta2(i,j)=0.0_r8
4763 ad_gzeta(i,j)=0.0_r8
4764#endif
4765!^ tl_zwrk(i,j)=cff5*tl_zeta_new(i,j)+cff4*tl_zeta(i,j,krhs)
4766!^
4767 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff5*ad_zwrk(i,j)
4768 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+cff4*ad_zwrk(i,j)
4769 ad_zwrk(i,j)=0.0_r8
4770!^ tl_Dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
4771!^
4772 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_dnew(i,j)
4773 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
4774 ad_dnew(i,j)=0.0_r8
4775#ifdef MASKING
4776!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4777!^
4778 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4779#endif
4780!^ tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
4781!^ & pm(i,j)*pn(i,j)*(tl_cff+ &
4782!^ & cff2*tl_rzeta(i,j,kstp)-&
4783!^ & cff3*tl_rzeta(i,j,ptsk))
4784!^
4785 adfac=pm(i,j)*pn(i,j)*ad_zeta_new(i,j)
4786 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_zeta_new(i,j)
4787 ad_cff=ad_cff+adfac
4788 ad_rzeta(i,j,kstp)=ad_rzeta(i,j,kstp)+adfac*cff2
4789 ad_rzeta(i,j,ptsk)=-adfac*cff3
4790 ad_zeta_new(i,j)=0.0_r8
4791!^ tl_cff=cff1*((tl_DUon(i,j)-tl_DUon(i+1,j))+ &
4792!^ & (tl_DVom(i,j)-tl_DVom(i,j+1)))
4793!^
4794 adfac=cff1*ad_cff
4795 ad_duon(i ,j )=ad_duon(i ,j )+adfac
4796 ad_duon(i+1,j )=ad_duon(i+1,j )-adfac
4797 ad_dvom(i ,j )=ad_dvom(i ,j )+adfac
4798 ad_dvom(i ,j+1)=ad_dvom(i ,j+1)-adfac
4799 ad_cff=0.0_r8
4800 END DO
4801 END DO
4802 END IF
4803
4804#ifdef WET_DRY_NOT_YET
4805!
4806!-----------------------------------------------------------------------
4807! Compute new wet/dry masks.
4808!-----------------------------------------------------------------------
4809!
4810!^ CALL wetdry_tile (ng, tile, &
4811!^ & LBi, UBi, LBj, UBj, &
4812!^ & IminS, ImaxS, JminS, JmaxS, &
4813# ifdef MASKING
4814!^ & pmask, rmask, umask, vmask, &
4815# endif
4816!^ & h, zeta(:,:,kstp), &
4817# ifdef SOLVE3D
4818!^ & DU_avg1, DV_avg1, &
4819!^ & rmask_wet_avg, &
4820# endif
4821!^ & pmask_wet, pmask_full, &
4822!^ & rmask_wet, rmask_full, &
4823!^ & umask_wet, umask_full, &
4824!^ & vmask_wet, vmask_full)
4825!^
4826!^ HGA: Need the ADM code here for the above NLM code.
4827!^
4828#endif
4829 END IF step_loop
4830
4831#ifdef SOLVE3D
4832!
4833!-----------------------------------------------------------------------
4834! Compute adjoint time averaged fields over all short timesteps.
4835!-----------------------------------------------------------------------
4836!
4837! After all fast time steps are completed, recompute S-coordinate
4838! surfaces according to the new free surface field. Apply boundary
4839! conditions to time averaged fields.
4840# ifdef NESTING
4841! In nesting applications with refinement grids, we need to exchange
4842! the DU_avg2 and DV_avg2 fluxes boundary information for the case
4843! that a contact point is at a tile partition. Notice that in such
4844! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
4845# endif
4846!
4847 IF ((iif(ng).eq.(nfast(ng)+1)).and.predictor_2d_step(ng)) THEN
4848
4849# ifdef DISTRIBUTE
4850# ifdef NESTING
4851!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
4852!^ & LBi, UBi, LBj, UBj, &
4853!^ & NghostPoints, &
4854!^ & EWperiodic(ng), NSperiodic(ng), &
4855!^ & tl_DU_avg2, tl_DV_avg2)
4856!^
4857 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
4858 & lbi, ubi, lbj, ubj, &
4859 & nghostpoints, &
4860 & ewperiodic(ng), nsperiodic(ng), &
4861 & ad_du_avg2, ad_dv_avg2)
4862# endif
4863!^ CALL mp_exchange2d (ng, tile, iTLM, 3, &
4864!^ & LBi, UBi, LBj, UBj, &
4865!^ & NghostPoints, &
4866!^ & EWperiodic(ng), NSperiodic(ng), &
4867!^ & tl_Zt_avg1, tl_DU_avg1, tl_DV_avg1)
4868!^
4869 CALL ad_mp_exchange2d (ng, tile, iadm, 3, &
4870 & lbi, ubi, lbj, ubj, &
4871 & nghostpoints, &
4872 & ewperiodic(ng), nsperiodic(ng), &
4873 & ad_zt_avg1, ad_du_avg1, ad_dv_avg1)
4874# endif
4875 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
4876# ifdef NESTING
4877!^ CALL exchange_v2d_tile (ng, tile, &
4878!^ & LBi, UBi, LBj, UBj, &
4879!^ & tl_DV_avg2)
4880!^
4881 CALL ad_exchange_v2d_tile (ng, tile, &
4882 & lbi, ubi, lbj, ubj, &
4883 & ad_dv_avg2)
4884!^ CALL exchange_u2d_tile (ng, tile, &
4885!^ & LBi, UBi, LBj, UBj, &
4886!^ & tl_DU_avg2)
4887 CALL ad_exchange_u2d_tile (ng, tile, &
4888 & lbi, ubi, lbj, ubj, &
4889 & ad_du_avg2)
4890# endif
4891!^ CALL exchange_v2d_tile (ng, tile, &
4892!^ & LBi, UBi, LBj, UBj, &
4893!^ & tl_DV_avg1)
4894!^
4895 CALL ad_exchange_v2d_tile (ng, tile, &
4896 & lbi, ubi, lbj, ubj, &
4897 & ad_dv_avg1)
4898!^ CALL exchange_u2d_tile (ng, tile, &
4899!^ & LBi, UBi, LBj, UBj, &
4900!^ & tl_DU_avg1)
4901!^
4902 CALL ad_exchange_u2d_tile (ng, tile, &
4903 & lbi, ubi, lbj, ubj, &
4904 & ad_du_avg1)
4905!^ CALL exchange_r2d_tile (ng, tile, &
4906!^ & LBi, UBi, LBj, UBj, &
4907!^ & tl_Zt_avg1)
4908!^
4909 CALL ad_exchange_r2d_tile (ng, tile, &
4910 & lbi, ubi, lbj, ubj, &
4911 & ad_zt_avg1)
4912 END IF
4913 END IF
4914!
4915! Compute time-averaged fields.
4916!
4917 IF (predictor_2d_step(ng)) THEN
4918 IF (first_2d_step) THEN
4919!
4920! Reset arrays for 2D fields averaged within the short time-steps.
4921!
4922 cff2=(-1.0_r8/12.0_r8)*weight(2,iif(ng)+1,ng)
4923 DO j=jstrr,jendr
4924 DO i=istrr,iendr
4925!^ tl_Zt_avg1(i,j)=0.0_r8
4926!^
4927 ad_zt_avg1(i,j)=0.0_r8
4928 END DO
4929 DO i=istr,iendr
4930!^ tl_DU_avg2(i,j)=cff2*tl_DUon(i,j)
4931!^
4932 ad_duon(i,j)=ad_duon(i,j)+cff2*ad_du_avg2(i,j)
4933 ad_du_avg2(i,j)=0.0_r8
4934!^ tl_DU_avg1(i,j)=0.0_r8
4935!^
4936 ad_du_avg1(i,j)=0.0_r8
4937 END DO
4938 END DO
4939 DO j=jstr,jendr
4940 DO i=istrr,iendr
4941!^ tl_DV_avg2(i,j)=cff2*tl_DVom(i,j)
4942!^
4943 ad_dvom(i,j)=ad_dvom(i,j)+cff2*ad_dv_avg2(i,j)
4944 ad_dv_avg2(i,j)=0.0_r8
4945!^ tl_DV_avg1(i,j)=0.0_r8
4946!^
4947 ad_dv_avg1(i,j)=0.0_r8
4948 END DO
4949 END DO
4950 ELSE
4951!
4952! Accumulate field averages of previous time-step after they are
4953! computed in the previous corrector step, updated their boundaries,
4954! and synchronized.
4955!
4956 cff1=weight(1,iif(ng)-1,ng)
4957 cff2=(8.0_r8/12.0_r8)*weight(2,iif(ng) ,ng)- &
4958 & (1.0_r8/12.0_r8)*weight(2,iif(ng)+1,ng)
4959 DO j=jstrr,jendr
4960 DO i=istrr,iendr
4961!^ tl_Zt_avg1(i,j)=tl_Zt_avg1(i,j)+cff1*tl_zeta(i,j,krhs)
4962!^
4963 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+cff1*ad_zt_avg1(i,j)
4964 END DO
4965 DO i=istr,iendr
4966!^ tl_DU_avg2(i,j)=tl_DU_avg2(i,j)+cff2*tl_DUon(i,j)
4967!^
4968 ad_duon(i,j)=ad_duon(i,j)+ &
4969 & cff2*ad_du_avg2(i,j)
4970# ifdef WEC_MELLOR
4971!^ tl_DU_avg1(i,j)=tl_DU_avg1(i,j)-cff1*tl_DUSon(i,j)
4972!^
4973 ad_duson(i,j)=ad_duson(i,j)- &
4974 & cff1*ad_du_avg1(i,j)
4975# endif
4976!^ tl_DU_avg1(i,j)=tl_DU_avg1(i,j)+cff1*tl_DUon(i,j)
4977!^
4978 ad_duon(i,j)=ad_duon(i,j)+ &
4979 & cff1*ad_du_avg1(i,j)
4980 END DO
4981 END DO
4982 DO j=jstr,jendr
4983 DO i=istrr,iendr
4984!^ tl_DV_avg2(i,j)=tl_DV_avg2(i,j)+cff2*tl_DVom(i,j)
4985!^
4986 ad_dvom(i,j)=ad_dvom(i,j)+ &
4987 & cff2*ad_dv_avg2(i,j)
4988# ifdef WEC_MELLOR
4989!^ tl_DV_avg1(i,j)=tl_DV_avg1(i,j)-cff1*tl_DVSom(i,j)
4990!^
4991 ad_dvsom(i,j)=ad_dvsom(i,j)- &
4992 & cff1*ad_dv_avg1(i,j)
4993# endif
4994!^ tl_DV_avg1(i,j)=tl_DV_avg1(i,j)+cff1*tl_DVom(i,j)
4995!^
4996 ad_dvom(i,j)=ad_dvom(i,j)+ &
4997 & cff1*ad_dv_avg1(i,j)
4998 END DO
4999 END DO
5000 END IF
5001 ELSE
5002 IF (first_2d_step) THEN
5003 cff2=weight(2,iif(ng),ng)
5004 ELSE
5005 cff2=(5.0_r8/12.0_r8)*weight(2,iif(ng),ng)
5006 END IF
5007 DO j=jstrr,jendr
5008 DO i=istr,iendr
5009!^ tl_DV_avg2(i,j)=tl_DV_avg2(i,j)+cff2*tl_DVom(i,j)
5010!^
5011 ad_dvom(i,j)=ad_dvom(i,j)+cff2*ad_dv_avg2(i,j)
5012 END DO
5013 END DO
5014 DO j=jstr,jendr
5015 DO i=istrr,iendr
5016!^ tl_DU_avg2(i,j)=tl_DU_avg2(i,j)+cff2*tl_DUon(i,j)
5017!^
5018 ad_duon(i,j)=ad_duon(i,j)+cff2*ad_du_avg2(i,j)
5019 END DO
5020 END DO
5021 END IF
5022#endif
5023!
5024!-----------------------------------------------------------------------
5025! Compute total depth (m) and vertically integrated mass fluxes.
5026!-----------------------------------------------------------------------
5027!
5028! Set vertically integrated mass fluxes DUon and DVom along the open
5029! boundaries in such a way that the integral volume is conserved.
5030!
5031 IF (any(ad_volcons(:,ng))) THEN
5032!^ CALL tl_set_DUV_bc_tile (ng, tile, &
5033!^ & LBi, UBi, LBj, UBj, &
5034!^ & IminS, ImaxS, JminS, JmaxS, &
5035!^ & krhs, &
5036#ifdef MASKING
5037!^ & umask, vmask, &
5038#endif
5039!^ & om_v, on_u, ubar, vbar, &
5040!^ & tl_ubar, tl_vbar, &
5041!^ & Drhs, DUon, DVom, &
5042!^ & tl_Drhs, tl_DUon, tl_DVom)
5043!^
5044 CALL ad_set_duv_bc_tile (ng, tile, &
5045 & lbi, ubi, lbj, ubj, &
5046 & imins, imaxs, jmins, jmaxs, &
5047 & krhs, &
5048#ifdef MASKING
5049 & umask, vmask, &
5050#endif
5051 & om_v, on_u, ubar, vbar, &
5052 & ad_ubar, ad_vbar, &
5053 & drhs, duon, dvom, &
5054 & ad_drhs, ad_duon, ad_dvom)
5055 END IF
5056
5057#ifdef DISTRIBUTE
5058!
5059! In distributed-memory, the I- and J-ranges are different and a
5060! special exchange is done to avoid having three ghost points for
5061! high order numerical stencils. Notice that a private array is
5062! passed below to the exchange routine. It also applies periodic
5063! boundary conditions, if appropriate and no partitions in I- or
5064! J-directions.
5065!
5066!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
5067!^ & IminS, ImaxS, JminS, JmaxS, &
5068!^ & NghostPoints, &
5069!^ & EWperiodic(ng), NSperiodic(ng), &
5070!^ & tl_DUon, tl_DVom)
5071!^
5072 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
5073 & imins, imaxs, jmins, jmaxs, &
5074 & nghostpoints, &
5075 & ewperiodic(ng), nsperiodic(ng), &
5076 & ad_duon, ad_dvom)
5077 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
5078!^ CALL exchange_u2d_tile (ng, tile, &
5079!^ & IminS, ImaxS, JminS, JmaxS, &
5080!^ & tl_DUon)
5081!^
5082 CALL ad_exchange_u2d_tile (ng, tile, &
5083 & imins, imaxs, jmins, jmaxs, &
5084 & ad_duon)
5085!^ CALL exchange_v2d_tile (ng, tile, &
5086!^ & IminS, ImaxS, JminS, JmaxS, &
5087!^ & tl_DVom)
5088!^
5089 CALL ad_exchange_v2d_tile (ng, tile, &
5090 & imins, imaxs, jmins, jmaxs, &
5091 & ad_dvom)
5092 END IF
5093#endif
5094#if defined DISTRIBUTE && !defined NESTING
5095!
5096! Compute adjoint adjoint vertically integrated mass fluxes.
5097!
5098 DO j=jstrv-1,jendp2
5099 DO i=istru-2,iendp2
5100 cff=0.5_r8*om_v(i,j)
5101 cff1=cff*(drhs(i,j)+drhs(i,j-1))
5102# ifdef WEC_MELLOR
5103!^ tl_DVom(i,j)=tl_DVom(i,j)+tl_DVSom(i,j)
5104!^
5105 ad_dvsom(i,j)=ad_dvsom(i,j)+ad_dvom(i,j)
5106!^ tl_DVSom(i,j)=tl_vbar_stokes(i,j)*cff1+ &
5107!^ & vbar_stokes(i,j)*tl_cff1
5108!^
5109 ad_cff1=ad_cff1+vbar_stokes(i,j)*ad_dvsom(i,j)
5110 ad_vbar_stokes(i,j)=ad_vbar_stokes(i,j)+cff1*ad_dvsom(i,j)
5111 ad_dvsom(i,j)=0.0_r8
5112# endif
5113!^ tl_DVom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
5114!^ & vbar(i,j,krhs)*tl_cff1
5115!^
5116 ad_cff1=ad_cff1+vbar(i,j,krhs)*ad_dvom(i,j)
5117 ad_vbar(i,j,krhs)=ad_vbar(i,j,krhs)+cff1*ad_dvom(i,j)
5118 ad_dvom(i,j)=0.0_r8
5119!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i,j-1))
5120!^
5121 adfac=cff*ad_cff1
5122 ad_drhs(i,j-1)=ad_drhs(i,j-1)+adfac
5123 ad_drhs(i,j )=ad_drhs(i,j )+adfac
5124 ad_cff1=0.0_r8
5125 END DO
5126 END DO
5127 DO j=jstrv-2,jendp2
5128 DO i=istru-1,iendp2
5129 cff=0.5_r8*on_u(i,j)
5130 cff1=cff*(drhs(i,j)+drhs(i-1,j))
5131# ifdef WEC_MELLOR
5132!^ tl_DUon(i,j)=tl_DUon(i,j)+tl_DUSon(i,j)
5133!^
5134 ad_duson(i,j)=ad_duson(i,j)+ad_duon(i,j)
5135!^ tl_DUSon(i,j)=tl_ubar_stokes(i,j)*cff1+ &
5136!^ & ubar_stokes(i,j)*tl_cff1
5137!^
5138 ad_cff1=ad_cff1+ubar_stokes(i,j)*ad_duson(i,j)
5139 ad_ubar_stokes(i,j)=ad_ubar_stokes(i,j)+cff1*ad_duson(i,j)
5140 ad_duson(i,j)=0.0_r8
5141# endif
5142!^ tl_DUon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
5143!^ & ubar(i,j,krhs)*tl_cff1
5144!^
5145 ad_cff1=ad_cff1+ubar(i,j,krhs)*ad_duon(i,j)
5146 ad_ubar(i,j,krhs)=ad_ubar(i,j,krhs)+cff1*ad_duon(i,j)
5147 ad_duon(i,j)=0.0_r8
5148!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i-1,j))
5149!^
5150 adfac=cff*ad_cff1
5151 ad_drhs(i-1,j)=ad_drhs(i-1,j)+adfac
5152 ad_drhs(i ,j)=ad_drhs(i ,j)+adfac
5153 ad_cff1=0.0_r8
5154 END DO
5155 END DO
5156!
5157! Compute adjoint total depth.
5158!
5159 DO j=jstrv-2,jendp2
5160 DO i=istru-2,iendp2
5161!^ tl_Drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
5162!^
5163 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+ad_drhs(i,j)
5164 ad_h(i,j)=ad_h(i,j)+ad_drhs(i,j)
5165 ad_drhs(i,j)=0.0_r8
5166 END DO
5167 END DO
5168
5169#else
5170
5171 DO j=jstrvm2,jendp2
5172 DO i=istrum2-1,iendp2
5173 cff=0.5_r8*om_v(i,j)
5174 cff1=cff*(drhs(i,j)+drhs(i,j-1))
5175# ifdef WEC_MELLOR
5176!^ tl_DVom(i,j)=tl_DVom(i,j)+tl_DVSom(i,j)
5177!^
5178 ad_dvsom(i,j)=ad_dvsom(i,j)+ad_dvom(i,j)
5179!^ tl_DVSom(i,j)=tl_vbar_stokes(i,j)*cff1+ &
5180!^ & vbar_stokes(i,j)*tl_cff1
5181!^
5182 ad_cff1=ad_cff1+vbar_stokes(i,j)*ad_dvsom(i,j)
5183 ad_vbar_stokes(i,j)=ad_vbar_stokes(i,j)+cff1*ad_dvsom(i,j)
5184 ad_dvsom(i,j)=0.0_r8
5185# endif
5186!^ tl_DVom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
5187!^ & vbar(i,j,krhs)*tl_cff1
5188!^
5189 ad_cff1=ad_cff1+vbar(i,j,krhs)*ad_dvom(i,j)
5190 ad_vbar(i,j,krhs)=ad_vbar(i,j,krhs)+cff1*ad_dvom(i,j)
5191 ad_dvom(i,j)=0.0_r8
5192!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i,j-1))
5193!^
5194 adfac=cff*ad_cff1
5195 ad_drhs(i,j-1)=ad_drhs(i,j-1)+adfac
5196 ad_drhs(i,j )=ad_drhs(i,j )+adfac
5197 ad_cff1=0.0_r8
5198 END DO
5199 END DO
5200 DO j=jstrvm2-1,jendp2
5201 DO i=istrum2,iendp2
5202 cff=0.5_r8*on_u(i,j)
5203 cff1=cff*(drhs(i,j)+drhs(i-1,j))
5204# ifdef WEC_MELLOR
5205!^ tl_DUon(i,j)=tl_DUon(i,j)+tl_DUSon(i,j)
5206!^
5207 ad_duson(i,j)=ad_duson(i,j)+ad_duon(i,j)
5208!^ tl_DUSon(i,j)=tl_ubar_stokes(i,j)*cff1+ &
5209!^ & ubar_stokes(i,j)*tl_cff1
5210!^
5211 ad_cff1=ad_cff1+ubar_stokes(i,j)*ad_duson(i,j)
5212 ad_ubar_stokes(i,j)=ad_ubar_stokes(i,j)+cff1*ad_duson(i,j)
5213 ad_duson(i,j)=0.0_r8
5214# endif
5215!^ tl_DUon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
5216!^ & ubar(i,j,krhs)*tl_cff1
5217!^
5218 ad_cff1=ad_cff1+ubar(i,j,krhs)*ad_duon(i,j)
5219 ad_ubar(i,j,krhs)=ad_ubar(i,j,krhs)+cff1*ad_duon(i,j)
5220 ad_duon(i,j)=0.0_r8
5221!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i-1,j))
5222!^
5223 adfac=cff*ad_cff1
5224 ad_drhs(i-1,j)=ad_drhs(i-1,j)+adfac
5225 ad_drhs(i ,j)=ad_drhs(i ,j)+adfac
5226 ad_cff1=0.0_r8
5227 END DO
5228 END DO
5229!
5230! Compute adjoint total depth.
5231!
5232 DO j=jstrvm2-1,jendp2
5233 DO i=istrum2-1,iendp2
5234!^ tl_Drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
5235!^
5236 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+ad_drhs(i,j)
5237 ad_h(i,j)=ad_h(i,j)+ad_drhs(i,j)
5238 ad_drhs(i,j)=0.0_r8
5239 END DO
5240 END DO
5241#endif
5242!
5243 RETURN
5244 END SUBROUTINE ad_step2d_tile
5245
5246 END MODULE ad_step2d_mod
ad_exchange_2d_mod
Definition ad_exchange_2d.F:2
ad_exchange_2d_mod::ad_exchange_u2d_tile
subroutine ad_exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:816
ad_exchange_2d_mod::ad_exchange_v2d_tile
subroutine ad_exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:1201
ad_exchange_2d_mod::ad_exchange_r2d_tile
subroutine ad_exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:431
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_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
ad_step2d_mod
Definition ad_step2d_FB.h:3
ad_step2d_mod::ad_step2d
subroutine, public ad_step2d(ng, tile)
Definition ad_step2d_FB.h:81
ad_step2d_mod::ad_step2d_tile
subroutine ad_step2d_tile(ng, tile, lbi, ubi, lbj, ubj, ubk, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, nnew, pmask, rmask, umask, vmask, pmask_wet, pmask_full, rmask_wet, rmask_full, umask_wet, umask_full, vmask_wet, vmask_full, rmask_wet_avg, fomn, h, ad_h, om_u, om_v, on_u, on_v, pm, pn, dndx, dmde, rdrag, rdrag2, pmon_r, pnom_r, pmon_p, pnom_p, om_r, on_r, om_p, on_p, visc2_p, visc2_r, visc4_p, visc4_r, ad_bed_thick, ad_rustr2d, ad_rvstr2d, ad_rulag2d, ad_rvlag2d, ubar_stokes, ad_ubar_stokes, vbar_stokes, ad_vbar_stokes, eq_tide, ad_eq_tide, sustr, ad_sustr, svstr, ad_svstr, pair, rhoa, ad_rhoa, rhos, ad_rhos, ad_du_avg1, ad_du_avg2, ad_dv_avg1, ad_dv_avg2, ad_zt_avg1, rufrc, ad_rufrc, rvfrc, ad_rvfrc, ad_rufrc_bak, ad_rvfrc_bak, ad_du_flux, ad_dv_flux, ad_ubar_sol, ad_vbar_sol, ad_zeta_sol, ubar, ad_ubar, vbar, ad_vbar, zeta, ad_zeta)
Definition ad_step2d_FB.h:301
ad_u2dbc_mod
Definition ad_u2dbc_im.F:2
ad_u2dbc_mod::ad_u2dbc_tile
subroutine, public ad_u2dbc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, kout, ubar, vbar, zeta, ad_ubar, ad_vbar, ad_zeta)
Definition ad_u2dbc_im.F:65
ad_v2dbc_mod
Definition ad_v2dbc_im.F:2
ad_v2dbc_mod::ad_v2dbc_tile
subroutine, public ad_v2dbc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, kout, ubar, vbar, zeta, ad_ubar, ad_vbar, ad_zeta)
Definition ad_v2dbc_im.F:65
ad_zetabc_mod
Definition ad_zetabc.F:2
ad_zetabc_mod::ad_zetabc_tile
subroutine, public ad_zetabc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, kout, zeta, ad_zeta)
Definition ad_zetabc.F:57
exchange_2d_mod
Definition exchange_2d.F:2
exchange_2d_mod::exchange_u2d_tile
subroutine exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:440
exchange_2d_mod::exchange_v2d_tile
subroutine exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:627
mod_clima
Definition mod_clima.F:2
mod_clima::clima
type(t_clima), dimension(:), allocatable clima
Definition mod_clima.F:153
mod_coupling
Definition mod_coupling.F:2
mod_coupling::coupling
type(t_coupling), dimension(:), allocatable coupling
Definition mod_coupling.F:102
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_mixing
Definition mod_mixing.F:2
mod_mixing::mixing
type(t_mixing), dimension(:), allocatable mixing
Definition mod_mixing.F:399
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::isvbar
integer isvbar
Definition mod_ncparam.F:505
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::ad_lbc
type(t_lbc), dimension(:,:,:), allocatable ad_lbc
Definition mod_param.F:378
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
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_scalars
Definition mod_scalars.F:2
mod_scalars::luvsrc
logical, dimension(:), allocatable luvsrc
Definition mod_scalars.F:542
mod_scalars::lnudgem2clm
logical, dimension(:), allocatable lnudgem2clm
Definition mod_scalars.F:533
mod_scalars::iic
integer, dimension(:), allocatable iic
Definition mod_scalars.F:249
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::ad_volcons
logical, dimension(:,:), allocatable ad_volcons
Definition mod_scalars.F:517
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::predictor_2d_step
logical, dimension(:), allocatable predictor_2d_step
Definition mod_scalars.F:245
mod_scalars::weight
real(dp), dimension(:,:,:), allocatable weight
Definition mod_scalars.F:809
mod_scalars::nfast
integer, dimension(:), allocatable nfast
Definition mod_scalars.F:259
mod_scalars::ndtfast
integer, dimension(:), allocatable ndtfast
Definition mod_scalars.F:258
mod_scalars::lwsrc
logical, dimension(:), allocatable lwsrc
Definition mod_scalars.F:543
mod_scalars::gamma2
real(r8), dimension(:), allocatable gamma2
Definition mod_scalars.F:743
mod_scalars::compositegrid
logical, dimension(:,:), allocatable compositegrid
Definition mod_scalars.F:493
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::dtfast
real(dp), dimension(:), allocatable dtfast
Definition mod_scalars.F:270
mod_scalars::ntfirst
integer, dimension(:), allocatable ntfirst
Definition mod_scalars.F:377
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::g
real(dp) g
Definition mod_scalars.F:464
mod_scalars::rho0
real(dp) rho0
Definition mod_scalars.F:787
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::iif
integer, dimension(:), allocatable iif
Definition mod_scalars.F:250
mod_sedbed
Definition sedbed_mod.h:1
mod_sedbed::sedbed
type(t_sedbed), dimension(:), allocatable sedbed
Definition sedbed_mod.h:157
mod_sources
Definition mod_sources.F:2
mod_sources::sources
type(t_sources), dimension(:), allocatable sources
Definition mod_sources.F:90
mod_sources::nsrc
integer, dimension(:), allocatable nsrc
Definition mod_sources.F:97
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::nnew
integer, dimension(:), allocatable nnew
Definition mod_stepping.F:69
mod_stepping::krhs
integer, dimension(:), allocatable krhs
Definition mod_stepping.F:65
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
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
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
obc_volcons_mod
Definition obc_volcons.F:3
obc_volcons_mod::set_duv_bc_tile
subroutine, public set_duv_bc_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kinp, umask, vmask, om_v, on_u, ubar, vbar, drhs, duon, dvom)
Definition obc_volcons.F:245
obc_volcons_mod::obc_flux_tile
subroutine, public obc_flux_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kinp, umask, vmask, h, om_v, on_u, ubar, vbar, zeta)
Definition obc_volcons.F:69
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