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

Functions/Subroutines

subroutine, public ad_step2d (ng, 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)
 
subroutine ad_step2d_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, 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, omn, pm, pn, dndx, dmde, pmon_r, pnom_r, pmon_p, pnom_p, om_r, on_r, om_p, on_p, visc2_p, visc2_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, bustr, ad_bustr, bvstr, ad_bvstr, 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)
 
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, omn, pm, pn, dndx, dmde, 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, ad_sustr, ad_svstr, ad_bustr, ad_bvstr, pair, rhoa, ad_rhoa, rhos, ad_rhos, ad_du_avg1, ad_du_avg2, ad_dv_avg1, ad_dv_avg2, zt_avg1, ad_zt_avg1, ad_rufrc, ad_rvfrc, ad_ru, ad_rv, ad_ubar_sol, ad_vbar_sol, ad_zeta_sol, rubar, ad_rubar, rvbar, ad_rvbar, rzeta, ad_rzeta, ubar, ad_ubar, vbar, ad_vbar, zeta, ad_zeta)
 

Function/Subroutine Documentation

◆ ad_step2d()

subroutine public ad_step2d_mod::ad_step2d ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 80 of file ad_step2d_FB.h.

81!***********************************************************************
82!
83! Imported variable declarations.
84!
85 integer, intent(in) :: ng, tile
86!
87! Local variable declarations.
88!
89 character (len=*), parameter :: MyFile = &
90 & __FILE__
91!
92#include "tile.h"
93!
94#ifdef PROFILE
95 CALL wclock_on (ng, iadm, 9, __line__, myfile)
96#endif
97 CALL ad_step2d_tile (ng, tile, &
98 & lbi, ubi, lbj, ubj, n(ng), &
99 & imins, imaxs, jmins, jmaxs, &
100 & krhs(ng), kstp(ng), knew(ng), &
101#ifdef SOLVE3D
102 & nstp(ng), nnew(ng), &
103#endif
104#ifdef MASKING
105 & grid(ng) % pmask, grid(ng) % rmask, &
106 & grid(ng) % umask, grid(ng) % vmask, &
107#endif
108#ifdef WET_DRY_NOT_YET
109 & grid(ng) % pmask_wet, grid(ng) % pmask_full, &
110 & grid(ng) % rmask_wet, grid(ng) % rmask_full, &
111 & grid(ng) % umask_wet, grid(ng) % umask_full, &
112 & grid(ng) % vmask_wet, grid(ng) % vmask_full, &
113# ifdef SOLVE3D
114 & grid(ng) % rmask_wet_avg, &
115# endif
116#endif
117#if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
118 & grid(ng) % fomn, &
119#endif
120 & grid(ng) % h, grid(ng) % ad_h, &
121 & grid(ng) % om_u, grid(ng) % om_v, &
122 & grid(ng) % on_u, grid(ng) % on_v, &
123 & grid(ng) % pm, grid(ng) % pn, &
124#if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
125 & grid(ng) % dndx, grid(ng) % dmde, &
126#endif
127 & grid(ng) % rdrag, &
128#if defined UV_QDRAG && !defined SOLVE3D
129 & grid(ng) % rdrag2, &
130#endif
131#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
132 & grid(ng) % pmon_r, grid(ng) % pnom_r, &
133 & grid(ng) % pmon_p, grid(ng) % pnom_p, &
134 & grid(ng) % om_r, grid(ng) % on_r, &
135 & grid(ng) % om_p, grid(ng) % on_p, &
136# ifdef UV_VIS2
137 & mixing(ng) % visc2_p, &
138 & mixing(ng) % visc2_r, &
139# endif
140# ifdef UV_VIS4
141 & mixing(ng) % visc4_p, &
142 & mixing(ng) % visc4_r, &
143# endif
144#endif
145#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
146 & sedbed(ng) % ad_bed_thick, &
147#endif
148#ifdef WEC_MELLOR
149 & mixing(ng) % ad_rustr2d, &
150 & mixing(ng) % ad_rvstr2d, &
151 & ocean(ng) % ad_rulag2d, &
152 & ocean(ng) % ad_rvlag2d, &
153 & ocean(ng) % ubar_stokes, &
154 & ocean(ng) % ad_ubar_stokes, &
155 & ocean(ng) % vbar_stokes, &
156 & ocean(ng) % ad_vbar_stokes, &
157#endif
158#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
159 & ocean(ng) % eq_tide, &
160 & ocean(ng) % ad_eq_tide, &
161#endif
162#ifndef SOLVE3D
163 & forces(ng) % sustr, forces(ng) % ad_sustr, &
164 & forces(ng) % svstr, forces(ng) % ad_svstr, &
165# ifdef ATM_PRESS
166 & forces(ng) % Pair, &
167# endif
168#else
169# ifdef VAR_RHO_2D
170 & coupling(ng) % rhoA, &
171 & coupling(ng) % ad_rhoA, &
172 & coupling(ng) % rhoS, &
173 & coupling(ng) % ad_rhoS, &
174# endif
175 & coupling(ng) % ad_DU_avg1, &
176 & coupling(ng) % ad_DU_avg2, &
177 & coupling(ng) % ad_DV_avg1, &
178 & coupling(ng) % ad_DV_avg2, &
179 & coupling(ng) % ad_Zt_avg1, &
180 & coupling(ng) % rufrc, &
181 & coupling(ng) % ad_rufrc, &
182 & coupling(ng) % rvfrc, &
183 & coupling(ng) % ad_rvfrc, &
184 & coupling(ng) % ad_rufrc_bak, &
185 & coupling(ng) % ad_rvfrc_bak, &
186#endif
187#if defined NESTING && !defined SOLVE3D
188 & ocean(ng) % ad_DU_flux, &
189 & ocean(ng) % ad_DV_flux, &
190#endif
191#ifdef DIAGNOSTICS_UV
192!! & DIAGS(ng) % DiaU2wrk, DIAGS(ng) % DiaV2wrk, &
193!! & DIAGS(ng) % DiaRUbar, DIAGS(ng) % DiaRVbar, &
194# ifdef SOLVE3D
195!! & DIAGS(ng) % DiaU2int, DIAGS(ng) % DiaV2int, &
196!! & DIAGS(ng) % DiaRUfrc, DIAGS(ng) % DiaRVfrc, &
197# endif
198#endif
199 & ocean(ng) % ad_ubar_sol, &
200 & ocean(ng) % ad_vbar_sol, &
201 & ocean(ng) % ad_zeta_sol, &
202 & ocean(ng) % ubar, ocean(ng) % ad_ubar, &
203 & ocean(ng) % vbar, ocean(ng) % ad_vbar, &
204 & ocean(ng) % zeta, ocean(ng) % ad_zeta)
205#ifdef PROFILE
206 CALL wclock_off (ng, iadm, 9, __line__, myfile)
207#endif
208!
209 RETURN
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References ad_step2d_tile(), mod_coupling::coupling, mod_forces::forces, mod_grid::grid, mod_param::iadm, mod_stepping::knew, mod_stepping::krhs, mod_stepping::kstp, mod_mixing::mixing, mod_param::n, mod_stepping::nnew, mod_stepping::nstp, mod_ocean::ocean, mod_sedbed::sedbed, wclock_off(), and wclock_on().

Referenced by ad_main3d().

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

◆ ad_step2d_tile() [1/3]

subroutine ad_step2d_mod::ad_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) omn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(inout) ad_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ad_eq_tide,
sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_sustr,
svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_svstr,
bustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_bustr,
bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rufrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rvfrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_ubar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_vbar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_zeta_sol,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_zeta )
private

Definition at line 202 of file ad_step2d_FB_LF_AM3.h.

283!***********************************************************************
284!
285! Imported variable declarations.
286!
287 integer, intent(in ) :: ng, tile
288 integer, intent(in ) :: LBi, UBi, LBj, UBj
289 integer, intent(in ) :: IminS, ImaxS, JminS, JmaxS
290 integer, intent(in ) :: kstp, knew
291#ifdef SOLVE3D
292 integer, intent(in ) :: nstp, nnew
293#endif
294!
295#ifdef ASSUMED_SHAPE
296# ifdef MASKING
297 real(r8), intent(in ) :: pmask(LBi:,LBj:)
298 real(r8), intent(in ) :: rmask(LBi:,LBj:)
299 real(r8), intent(in ) :: umask(LBi:,LBj:)
300 real(r8), intent(in ) :: vmask(LBi:,LBj:)
301# endif
302# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
303 real(r8), intent(in ) :: fomn(LBi:,LBj:)
304# endif
305 real(r8), intent(in ) :: h(LBi:,LBj:)
306 real(r8), intent(in ) :: om_u(LBi:,LBj:)
307 real(r8), intent(in ) :: om_v(LBi:,LBj:)
308 real(r8), intent(in ) :: on_u(LBi:,LBj:)
309 real(r8), intent(in ) :: on_v(LBi:,LBj:)
310 real(r8), intent(in ) :: omn(LBi:,LBj:)
311 real(r8), intent(in ) :: pm(LBi:,LBj:)
312 real(r8), intent(in ) :: pn(LBi:,LBj:)
313# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
314 real(r8), intent(in ) :: dndx(LBi:,LBj:)
315 real(r8), intent(in ) :: dmde(LBi:,LBj:)
316# endif
317 real(r8), intent(in ) :: rufrc(LBi:,LBj:)
318 real(r8), intent(in ) :: rvfrc(LBi:,LBj:)
319# if defined UV_VIS2 && !defined SOLVE3D
320 real(r8), intent(in ) :: pmon_r(LBi:,LBj:)
321 real(r8), intent(in ) :: pnom_r(LBi:,LBj:)
322 real(r8), intent(in ) :: pmon_p(LBi:,LBj:)
323 real(r8), intent(in ) :: pnom_p(LBi:,LBj:)
324 real(r8), intent(in ) :: om_r(LBi:,LBj:)
325 real(r8), intent(in ) :: on_r(LBi:,LBj:)
326 real(r8), intent(in ) :: om_p(LBi:,LBj:)
327 real(r8), intent(in ) :: on_p(LBi:,LBj:)
328 real(r8), intent(in ) :: visc2_p(LBi:,LBj:)
329 real(r8), intent(in ) :: visc2_r(LBi:,LBj:)
330# endif
331# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
332 real(r8), intent(inout) :: ad_bed_thick(LBi:,LBj:,:)
333# endif
334# ifdef WEC_MELLOR
335 real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:)
336 real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:)
337# endif
338# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
339 real(r8), intent(in ) :: eq_tide(LBi:,LBj:)
340 real(r8), intent(inout) :: ad_eq_tide(LBi:,LBj:)
341# endif
342 real(r8), intent(in ) :: ubar(LBi:,LBj:,:)
343 real(r8), intent(in ) :: vbar(LBi:,LBj:,:)
344 real(r8), intent(in ) :: zeta(LBi:,LBj:,:)
345 real(r8), intent(inout) :: ad_h(LBi:,LBj:)
346# ifndef SOLVE3D
347 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
348 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
349 real(r8), intent(inout) :: ad_bustr(LBi:,LBj:)
350 real(r8), intent(inout) :: ad_bvstr(LBi:,LBj:)
351# ifdef ATM_PRESS
352 real(r8), intent(inout) :: Pair(LBi:,LBj:)
353# endif
354# else
355# ifdef VAR_RHO_2D
356 real(r8), intent(in ) :: rhoA(LBi:,LBj:)
357 real(r8), intent(in ) :: rhoS(LBi:,LBj:)
358 real(r8), intent(inout) :: ad_rhoA(LBi:,LBj:)
359 real(r8), intent(inout) :: ad_rhoS(LBi:,LBj:)
360# endif
361
362 real(r8), intent(inout) :: ad_DU_avg1(LBi:,LBj:)
363 real(r8), intent(inout) :: ad_DU_avg2(LBi:,LBj:)
364 real(r8), intent(inout) :: ad_DV_avg1(LBi:,LBj:)
365 real(r8), intent(inout) :: ad_DV_avg2(LBi:,LBj:)
366 real(r8), intent(inout) :: ad_Zt_avg1(LBi:,LBj:)
367 real(r8), intent(inout) :: ad_rufrc(LBi:,LBj:)
368 real(r8), intent(inout) :: ad_rvfrc(LBi:,LBj:)
369 real(r8), intent(inout) :: ad_rufrc_bak(LBi:,LBj:,:)
370 real(r8), intent(inout) :: ad_rvfrc_bak(LBi:,LBj:,:)
371# endif
372# ifdef WEC_MELLOR
373 real(r8), intent(inout) :: ad_rustr2d(LBi:,LBj:)
374 real(r8), intent(inout) :: ad_rvstr2d(LBi:,LBj:)
375 real(r8), intent(inout) :: ad_rulag2d(LBi:,LBj:)
376 real(r8), intent(inout) :: ad_rvlag2d(LBi:,LBj:)
377 real(r8), intent(inout) :: ad_ubar_stokes(LBi:,LBj:)
378 real(r8), intent(inout) :: ad_vbar_stokes(LBi:,LBj:)
379# endif
380# ifdef WET_DRY_NOT_YET
381 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
382 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
383 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
384 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
385
386 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
387 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
388 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
389 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
390# ifdef SOLVE3D
391 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
392# endif
393# endif
394# ifdef DIAGNOSTICS_UV
395!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
396!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
397!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
398!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
399# ifdef SOLVE3D
400!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
401!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
402!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
403!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
404# endif
405# endif
406 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
407 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
408 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
409# if defined NESTING && !defined SOLVE3D
410 real(r8), intent(inout) :: ad_DU_flux(LBi:,LBj:)
411 real(r8), intent(inout) :: ad_DV_flux(LBi:,LBj:)
412# endif
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
417#else
418
419# ifdef MASKING
420 real(r8), intent(in ) :: pmask(LBi:UBi,LBj:UBj)
421 real(r8), intent(in ) :: rmask(LBi:UBi,LBj:UBj)
422 real(r8), intent(in ) :: umask(LBi:UBi,LBj:UBj)
423 real(r8), intent(in ) :: vmask(LBi:UBi,LBj:UBj)
424# endif
425# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
426 real(r8), intent(in ) :: fomn(LBi:UBi,LBj:UBj)
427# endif
428 real(r8), intent(in ) :: h(LBi:UBi,LBj:UBj)
429 real(r8), intent(in ) :: om_u(LBi:UBi,LBj:UBj)
430 real(r8), intent(in ) :: om_v(LBi:UBi,LBj:UBj)
431 real(r8), intent(in ) :: on_u(LBi:UBi,LBj:UBj)
432 real(r8), intent(in ) :: on_v(LBi:UBi,LBj:UBj)
433 real(r8), intent(in ) :: omn(LBi:UBi,LBj:UBj)
434 real(r8), intent(in ) :: pm(LBi:UBi,LBj:UBj)
435 real(r8), intent(in ) :: pn(LBi:UBi,LBj:UBj)
436# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
437 real(r8), intent(in ) :: dndx(LBi:UBi,LBj:UBj)
438 real(r8), intent(in ) :: dmde(LBi:UBi,LBj:UBj)
439# endif
440 real(r8), intent(in ) :: rufrc(LBi:UBi,LBj:UBj)
441 real(r8), intent(in ) :: rvfrc(LBi:UBi,LBj:UBj)
442# if defined UV_VIS2 && !defined SOLVE3D
443 real(r8), intent(in ) :: pmon_r(LBi:UBi,LBj:UBj)
444 real(r8), intent(in ) :: pnom_r(LBi:UBi,LBj:UBj)
445 real(r8), intent(in ) :: pmon_p(LBi:UBi,LBj:UBj)
446 real(r8), intent(in ) :: pnom_p(LBi:UBi,LBj:UBj)
447 real(r8), intent(in ) :: om_r(LBi:UBi,LBj:UBj)
448 real(r8), intent(in ) :: on_r(LBi:UBi,LBj:UBj)
449 real(r8), intent(in ) :: om_p(LBi:UBi,LBj:UBj)
450 real(r8), intent(in ) :: on_p(LBi:UBi,LBj:UBj)
451 real(r8), intent(in ) :: visc2_p(LBi:UBi,LBj:UBj)
452 real(r8), intent(in ) :: visc2_r(LBi:UBi,LBj:UBj)
453# endif
454# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
455 real(r8), intent(inout) :: ad_bed_thick(LBi:UBi,LBj:UBj,3)
456# endif
457# ifdef WEC_MELLOR
458 real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj)
459 real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj)
460# endif
461# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
462 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
463 real(r8), intent(in ) :: ad_eq_tide(LBi:UBi,LBj:UBj)
464# endif
465 real(r8), intent(in ) :: ubar(LBi:UBi,LBj:UBj,:)
466 real(r8), intent(in ) :: vbar(LBi:UBi,LBj:UBj,:)
467 real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:)
468 real(r8), intent(inout) :: ad_h(LBi:UBi,LBj:UBj)
469# ifndef SOLVE3D
470 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
471 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
472 real(r8), intent(inout) :: ad_bustr(LBi:UBi,LBj:UBj)
473 real(r8), intent(inout) :: ad_bvstr(LBi:UBi,LBj:UBj)
474# ifdef ATM_PRESS
475 real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj)
476# endif
477# else
478# ifdef VAR_RHO_2D
479 real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj)
480 real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj)
481 real(r8), intent(inout) :: ad_rhoA(LBi:UBi,LBj:UBj)
482 real(r8), intent(inout) :: ad_rhoS(LBi:UBi,LBj:UBj)
483# endif
484 real(r8), intent(inout) :: ad_DU_avg1(LBi:UBi,LBj:UBj)
485 real(r8), intent(inout) :: ad_DU_avg2(LBi:UBi,LBj:UBj)
486 real(r8), intent(inout) :: ad_DV_avg1(LBi:UBi,LBj:UBj)
487 real(r8), intent(inout) :: ad_DV_avg2(LBi:UBi,LBj:UBj)
488 real(r8), intent(inout) :: ad_Zt_avg1(LBi:UBi,LBj:UBj)
489 real(r8), intent(inout) :: ad_rufrc(LBi:UBi,LBj:UBj)
490 real(r8), intent(inout) :: ad_rvfrc(LBi:UBi,LBj:UBj)
491 real(r8), intent(inout) :: ad_rufrc_bak(LBi:UBi,LBj:UBj,2)
492 real(r8), intent(inout) :: ad_rvfrc_bak(LBi:UBi,LBj:UBj,2)
493# endif
494# ifdef WEC_MELLOR
495 real(r8), intent(inout) :: ad_rustr2d(LBi:UBi,LBj:UBj)
496 real(r8), intent(inout) :: ad_rvstr2d(LBi:UBi,LBj:UBj)
497 real(r8), intent(inout) :: ad_rulag2d(LBi:UBi,LBj:UBj)
498 real(r8), intent(inout) :: ad_rvlag2d(LBi:UBi,LBj:UBj)
499 real(r8), intent(inout) :: ad_ubar_stokes(LBi:UBi,LBj:UBj)
500 real(r8), intent(inout) :: ad_vbar_stokes(LBi:UBi,LBj:UBj)
501# endif
502# ifdef WET_DRY_NOT_YET
503 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
504 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
505 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
506 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
507
508 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
509 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
510 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
511 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
512# ifdef SOLVE3D
513 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
514# endif
515# endif
516# ifdef DIAGNOSTICS_UV
517!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
518!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
519!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
520!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
521# ifdef SOLVE3D
522!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
523!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
524!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
525!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
526# endif
527# endif
528 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
529 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
530 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
531# if defined NESTING && !defined SOLVE3D
532 real(r8), intent(inout) :: ad_DU_flux(LBi:UBi,LBj:UBj)
533 real(r8), intent(inout) :: ad_DV_flux(LBi:UBi,LBj:UBj)
534# endif
535 real(r8), intent(out ) :: ad_ubar_sol(LBi:UBi,LBj:UBj)
536 real(r8), intent(out ) :: ad_vbar_sol(LBi:UBi,LBj:UBj)
537 real(r8), intent(out ) :: ad_zeta_sol(LBi:UBi,LBj:UBj)
538#endif
539!
540! Local variable declarations.
541!
542 integer :: i, is, j
543 integer :: krhs, kbak
544#ifdef DIAGNOSTICS_UV
545 integer :: idiag
546#endif
547!
548 real(r8) :: cff, cff1, cff2, cff3, cff4
549#ifdef WET_DRY_NOT_YET
550 real(r8) :: cff5, cff6, cff7
551#endif
552 real(r8) :: fac, fac1, fac2
553 real(r8) :: ad_cff, ad_cff1, ad_cff2, ad_cff3, ad_cff4
554#ifdef WET_DRY_NOT_YET
555 real(r8) :: ad_cff5, ad_cff6, ad_cff7
556#endif
557 real(r8) :: ad_fac, ad_fac1, ad_fac2
558 real(r8) :: adfac, adfac1, adfac2, adfac3, adfac4, adfac5
559!
560 real(r8), parameter :: IniVal = 0.0_r8
561!
562#if defined UV_C4ADVECTION && !defined SOLVE3D
563 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
564#endif
565 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
566 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
567#if defined UV_VIS2 && !defined SOLVE3D
568 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
569#endif
570 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
571 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
572 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
573#ifdef WEC_MELLOR
574 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
575 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
576#endif
577#if defined STEP2D_CORIOLIS || !defined SOLVE3D
578 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
579 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
580#endif
581#if !defined SOLVE3D
582 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
583 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
584#endif
585#if defined UV_C4ADVECTION && !defined SOLVE3D
586 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
587#endif
588 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar
589 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar
590 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta
591 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2
592#if defined VAR_RHO_2D && defined SOLVE3D
593 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA
594#endif
595 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
596 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
597#ifdef WET_DRY_NOT_YET
598 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
599#endif
600#ifdef DIAGNOSTICS_UV
601!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
602!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
603!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaU2rhs
604!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaV2rhs
605#endif
606!
607#if defined UV_C4ADVECTION && !defined SOLVE3D
608 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dgrad
609#endif
610 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dnew
611 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs
612#if defined UV_VIS2 && !defined SOLVE3D
613 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs_p
614#endif
615 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dstp
616 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUon
617 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVom
618#ifdef WEC_MELLOR
619 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUSon
620 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVSom
621#endif
622#if defined STEP2D_CORIOLIS || !defined SOLVE3D
623 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFx
624 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFe
625#endif
626#if !defined SOLVE3D
627 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFe
628 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFx
629#endif
630#if defined UV_C4ADVECTION && !defined SOLVE3D
631 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad
632#endif
633 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta2
634#if defined VAR_RHO_2D && defined SOLVE3D
635 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzetaSA
636#endif
637 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta
638 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rubar
639 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rvbar
640 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_zwrk
641!
642 real(r8), allocatable :: ad_zeta_new(:,:)
643!
644! The following stability limits are obtained empirically using 3/4
645! degree Atlantic model configuration. In all these cases barotropic
646! mode time step is about 180...250 seconds, which is much less than
647! the inertial period. The maximum stability coefficients turned out
648! to be slightly different than predicted by linear theory, although
649! all theoretical tendencies agree with the practice. Note the nearly
650! 70% gain in stability compared with LF-TR for appropriate
651! coefficients (linear theory predicts beta=0.166, epsil=0.84).
652!
653!! real(r8), parameter :: gamma=0.0_r8, &
654!! & beta =0.0_r8, epsil=0.0_r8 !--> Cu=0.818
655!! real(r8), parameter :: gamma=1.0_r8/12.0_r8, &
656!! & beta =0.0_r8, epsil=0.0_r8 !--> Cu=0.878
657!! real(r8), parameter :: gamma=1./12., &
658!! beta =0.1_r8, epsil=0.6_r8 !--> Cu=1.050
659 real(r8), parameter :: gamma=0.0_r8, &
660 & beta =0.14_r8, epsil=0.74_r8 !==> Cu=1.341
661
662#include "set_bounds.h"
663!
664!-----------------------------------------------------------------------
665! Timestep vertically integrated (barotropic) equations.
666!-----------------------------------------------------------------------
667!
668! In the code below it is assumed that variables with time index "krhs"
669! are time-centered at step "n" in barotropic time during predictor
670! sub-step and "n+1/2" during corrector.
671!
672 IF (predictor_2d_step) THEN
673 krhs=kstp
674 ELSE
675 krhs=3
676 END IF
677 IF (first_2d_step) THEN
678 kbak=kstp ! "kbak" is used as "from"
679 ELSE ! time index for LF timestep
680 kbak=3-kstp
681 END IF
682
683#ifdef DEBUG
684!
685 IF (master) THEN
686 WRITE (20,10) iic(ng), iif(ng), kbak, krhs, kstp, knew
687 10 FORMAT (' iic = ',i5.5,' iif = ',i3.3, &
688 & ' kbak = ',i1,' krhs = ',i1,' kstp = ',i1,' knew = ',i1)
689 END IF
690#endif
691!
692!-----------------------------------------------------------------------
693! Initialize adjoint private variables.
694!-----------------------------------------------------------------------
695!
696 ad_cff=inival
697 ad_cff1=inival
698 ad_cff2=inival
699 ad_cff3=inival
700 ad_cff4=inival
701 ad_fac=inival
702 ad_fac1=inival
703 ad_fac2=inival
704!
705#if defined UV_C4ADVECTION && !defined SOLVE3D
706 ad_dgrad=inival
707#endif
708 ad_dnew=inival
709 ad_drhs=inival
710#if defined UV_VIS2 && !defined SOLVE3D
711 ad_drhs_p=inival
712#endif
713 ad_dstp=inival
714 ad_duon=inival
715 ad_dvom=inival
716#ifdef WEC_MELLOR
717 ad_duson=inival
718 ad_dvsom=inival
719#endif
720#if defined STEP2D_CORIOLIS || !defined SOLVE3D
721 ad_ufx=inival
722 ad_vfe=inival
723#endif
724#if !defined SOLVE3D
725 ad_ufe=inival
726 ad_vfx=inival
727#endif
728#if defined UV_C4ADVECTION && !defined SOLVE3D
729 ad_grad=inival
730#endif
731 ad_rzeta2=inival
732#if defined VAR_RHO_2D && defined SOLVE3D
733 ad_rzetasa=inival
734#endif
735 ad_rzeta=inival
736 ad_rubar=inival
737 ad_rvbar=inival
738 ad_zwrk=inival
739!
740!-----------------------------------------------------------------------
741! Compute BASIC STATE total depth (m) arrays and vertically
742! integerated mass fluxes.
743!-----------------------------------------------------------------------
744!
745#if defined DISTRIBUTE && !defined NESTING
746# define IR_RANGE IstrUm2-1,Iendp2
747# define JR_RANGE JstrVm2-1,Jendp2
748# define IU_RANGE IstrUm1-1,Iendp2
749# define JU_RANGE Jstrm1-1,Jendp2
750# define IV_RANGE Istrm1-1,Iendp2
751# define JV_RANGE JstrVm1-1,Jendp2
752#else
753# define IR_RANGE IstrUm2-1,Iendp2
754# define JR_RANGE JstrVm2-1,Jendp2
755# define IU_RANGE IstrUm2,Iendp2
756# define JU_RANGE JstrVm2-1,Jendp2
757# define IV_RANGE IstrUm2-1,Iendp2
758# define JV_RANGE JstrVm2,Jendp2
759#endif
760
761 DO j=jr_range
762 DO i=ir_range
763 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
764 END DO
765 END DO
766 DO j=ju_range
767 DO i=iu_range
768 cff=0.5_r8*on_u(i,j)
769 cff1=cff*(drhs(i,j)+drhs(i-1,j))
770 duon(i,j)=ubar(i,j,krhs)*cff1
771 END DO
772 END DO
773 DO j=jv_range
774 DO i=iv_range
775 cff=0.5_r8*om_v(i,j)
776 cff1=cff*(drhs(i,j)+drhs(i,j-1))
777 dvom(i,j)=vbar(i,j,krhs)*cff1
778 END DO
779 END DO
780
781#undef IR_RANGE
782#undef IU_RANGE
783#undef IV_RANGE
784#undef JR_RANGE
785#undef JU_RANGE
786#undef JV_RANGE
787
788#if defined DISTRIBUTE && \
789 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
790!
791! In distributed-memory, the I- and J-ranges are different and a
792! special exchange is done here to avoid having three ghost points
793! for high-order numerical stencils. Notice that a private array is
794! passed below to the exchange routine. It also applies periodic
795! boundary conditions, if appropriate and no partitions in I- or
796! J-directions.
797!
798 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
799 CALL exchange_u2d_tile (ng, tile, &
800 & imins, imaxs, jmins, jmaxs, &
801 & duon)
802 CALL exchange_v2d_tile (ng, tile, &
803 & imins, imaxs, jmins, jmaxs, &
804 & dvom)
805 END IF
806 CALL mp_exchange2d (ng, tile, inlm, 2, &
807 & imins, imaxs, jmins, jmaxs, &
808 & nghostpoints, &
809 & ewperiodic(ng), nsperiodic(ng), &
810 & duon, dvom)
811#endif
812!
813! Compute integral mass flux across open boundaries and adjust
814! for volume conservation. Compute BASIC STATE value.
815!
816 IF (any(volcons(:,ng))) THEN
817 CALL obc_flux_tile (ng, tile, &
818 & lbi, ubi, lbj, ubj, &
819 & imins, imaxs, jmins, jmaxs, &
820 & knew, &
821#ifdef MASKING
822 & umask, vmask, &
823#endif
824 & h, om_v, on_u, &
825 & ubar, vbar, zeta)
826!
827! Set vertically integrated mass fluxes DUon and DVom along the open
828! boundaries in such a way that the integral volume is conserved.
829!
830 CALL set_duv_bc_tile (ng, tile, &
831 & lbi, ubi, lbj, ubj, &
832 & imins, imaxs, jmins, jmaxs, &
833 & krhs, &
834#ifdef MASKING
835 & umask, vmask, &
836#endif
837 & om_v, on_u, &
838 & ubar, vbar, &
839 & drhs, duon, dvom)
840 END IF
841!
842!-----------------------------------------------------------------------
843! Compute BASIC STATE fields associated with pressure gradient and
844! time-stepping of adjoint free-surface, "zeta_new".
845!-----------------------------------------------------------------------
846!
847! Get background zeta_new from BASIC state. Notice the I- and J-range
848! used to avoid calling nonlinear 'zetabc_local' routine.
849!
850 DO j=lbj,ubj
851 DO i=lbi,ubi
852 zeta_new(i,j)=zeta(i,j,knew)
853#ifdef MASKING
854 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
855# ifdef WET_DRY_NOT_YET
856!^ zeta_new(i,j)=zeta_new(i,j)+ &
857!^ & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
858# endif
859#endif
860 dnew(i,j)=h(i,j)+zeta_new(i,j)
861 dstp(i,j)=h(i,j)+zeta(i,j,kstp)
862 END DO
863 END DO
864!
865! Notice that the new local free-surface is allocated so it can be
866! passed as an argumment to "zetabc_local". An automatic array cannot
867! be used here because of weird memory problems.
868!
869 allocate ( ad_zeta_new(imins:imaxs,jmins:jmaxs) )
870 ad_zeta_new = 0.0_r8
871
872 IF (predictor_2d_step) THEN
873 IF (first_2d_step) THEN ! Modified RK2 time step (with
874 cff=dtfast(ng) ! Forward-Backward feedback with
875#ifdef SOLVE3D
876 cff1=0.0_r8 !==> Forward Euler
877 cff2=1.0_r8
878#else
879 cff1=0.333333333333_r8 ! optimally chosen beta=1/3 and
880 cff2=0.666666666667_r8 ! epsilon=2/3, see below) is used
881#endif
882 cff3=0.0_r8 ! here for the start up.
883 ELSE
884 cff=2.0_r8*dtfast(ng) ! In the code below "zwrk" is
885 cff1=beta ! time-centered at time step "n"
886 cff2=1.0_r8-2.0_r8*beta ! in the case of LF (for all but
887 cff3=beta ! the first time step)
888 END IF
889!
890 DO j=jstrv-1,jend
891 DO i=istru-1,iend
892!^ fac=cff*pm(i,j)*pn(i,j)
893!^ zeta_new(i,j)=zeta(i,j,kbak)+ &
894!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
895!^ & DVom(i,j)-DVom(i,j+1))
896#ifdef MASKING
897!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
898# ifdef WET_DRY
899!^ zeta_new(i,j)=zeta_new(i,j)+ &
900!^ & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
901# endif
902#endif
903!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
904! using background instead
905 zwrk(i,j)=cff1*zeta_new(i,j)+ &
906 & cff2*zeta(i,j,kstp)+ &
907 & cff3*zeta(i,j,kbak)
908#if defined VAR_RHO_2D && defined SOLVE3D
909 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
910 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
911 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
912#else
913 rzeta(i,j)=zwrk(i,j)
914 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
915#endif
916 END DO
917 END DO
918 ELSE !--> CORRECTOR STEP
919 IF (first_2d_step) THEN
920 cff =0.333333333333_r8 ! Modified RK2 weighting:
921 cff1=0.333333333333_r8 ! here "zwrk" is time-
922 cff2=0.333333333333_r8 ! centered at "n+1/2".
923 cff3=0.0_r8
924 ELSE
925 cff =1.0_r8-epsil ! zwrk is always time-
926 cff1=(0.5_r8-gamma)*epsil ! centered at n+1/2
927 cff2=(0.5_r8+2.0_r8*gamma)*epsil ! during corrector sub-
928 cff3=-gamma *epsil ! step.
929 END IF
930!
931 DO j=jstrv-1,jend
932 DO i=istru-1,iend
933!^ fac=dtfast(ng)*pm(i,j)*pn(i,j)
934!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
935!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
936!^ & DVom(i,j)-DVom(i,j+1))
937#ifdef MASKING
938!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
939#endif
940!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
941! using background instead
942 zwrk(i,j)=cff *zeta(i,j,krhs)+ &
943 & cff1*zeta_new(i,j)+ &
944 & cff2*zeta(i,j,kstp)+ &
945 & cff3*zeta(i,j,kbak)
946#if defined VAR_RHO_2D && defined SOLVE3D
947 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
948 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
949 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
950#else
951 rzeta(i,j)=zwrk(i,j)
952 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
953#endif
954 END DO
955 END DO
956 END IF
957!
958!-----------------------------------------------------------------------
959! Save adjoint 2D solution at knew index for IO purposes.
960!-----------------------------------------------------------------------
961!
962#ifdef SOLVE3D
963 IF (iif(ng).eq.nfast(ng)) THEN
964 DO j=jstrr,jendr
965 DO i=istrr,iendr
966 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
967 END DO
968 DO i=istr,iendr
969 ad_ubar_sol(i,j)=ad_ubar(i,j,knew)
970 END DO
971 IF (j.ge.jstr) THEN
972 DO i=istrr,iendr
973 ad_vbar_sol(i,j)=ad_vbar(i,j,knew)
974 END DO
975 END IF
976 END DO
977 END IF
978#else
979 DO j=jstrr,jendr
980 DO i=istrr,iendr
981 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
982 END DO
983 DO i=istr,iendr
984 ad_ubar_sol(i,j)=ad_ubar(i,j,knew)
985 END DO
986 IF (j.ge.jstr) THEN
987 DO i=istrr,iendr
988 ad_vbar_sol(i,j)=ad_vbar(i,j,knew)
989 END DO
990 END IF
991 END DO
992#endif
993!
994!-----------------------------------------------------------------------
995! Adjoint of Exchange boundary information.
996!-----------------------------------------------------------------------
997!
998#ifdef DISTRIBUTE
999!^ CALL mp_exchange2d (ng, tile, iTLM, 3, &
1000!^ & LBi, UBi, LBj, UBj, &
1001!^ & NghostPoints, &
1002!^ & EWperiodic(ng), NSperiodic(ng), &
1003!^ & tl_zeta(:,:,knew), &
1004!^ & tl_ubar(:,:,knew), &
1005!^ & tl_vbar(:,:,knew))
1006!^
1007 CALL ad_mp_exchange2d (ng, tile, iadm, 3, &
1008 & lbi, ubi, lbj, ubj, &
1009 & nghostpoints, &
1010 & ewperiodic(ng), nsperiodic(ng), &
1011 & ad_zeta(:,:,knew), &
1012 & ad_ubar(:,:,knew), &
1013 & ad_vbar(:,:,knew))
1014
1015#endif
1016 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1017!^ CALL exchange_v2d_tile (ng, tile, &
1018!^ & LBi, UBi, LBj, UBj, &
1019!^ & tl_vbar(:,:,knew))
1020!^
1021 CALL ad_exchange_v2d_tile (ng, tile, &
1022 & lbi, ubi, lbj, ubj, &
1023 & ad_vbar(:,:,knew))
1024!^ CALL exchange_u2d_tile (ng, tile, &
1025!^ & LBi, UBi, LBj, UBj, &
1026!^ & tl_ubar(:,:,knew))
1027!^
1028 CALL ad_exchange_u2d_tile (ng, tile, &
1029 & lbi, ubi, lbj, ubj, &
1030 & ad_ubar(:,:,knew))
1031!^ CALL exchange_r2d_tile (ng, tile, &
1032!^ & LBi, UBi, LBj, UBj, &
1033!^ & tl_zeta(:,:,knew))
1034!^
1035 CALL ad_exchange_r2d_tile (ng, tile, &
1036 & lbi, ubi, lbj, ubj, &
1037 & ad_zeta(:,:,knew))
1038 END IF
1039
1040#ifdef WET_DRY_NOT_YET
1041!
1042!-----------------------------------------------------------------------
1043! Adjoint of compute new wet/dry masks.
1044!-----------------------------------------------------------------------
1045!
1046!^ CALL wetdry_tile (ng, tile, &
1047!^ & LBi, UBi, LBj, UBj, &
1048!^ & IminS, ImaxS, JminS, JmaxS, &
1049# ifdef MASKING
1050!^ & pmask, rmask, umask, vmask, &
1051# endif
1052!^ & h, zeta(:,:,knew), &
1053# ifdef SOLVE3D
1054!^ & DU_avg1, DV_avg1, &
1055!^ & rmask_wet_avg, &
1056# endif
1057!^ & pmask_wet, pmask_full, &
1058!^ & rmask_wet, rmask_full, &
1059!^ & umask_wet, umask_full, &
1060!^ & vmask_wet, vmask_full)
1061!^
1062!^ HGA: Need the TLM code here.
1063!^
1064#endif
1065
1066#if defined NESTING && !defined SOLVE3D
1067!
1068!-----------------------------------------------------------------------
1069! In nesting applications with refinement grids, we need to exchange
1070! the DU_flux and DV_flux fluxes boundary information for the case
1071! that a contact point is at a tile partition. Notice that in such
1072! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
1073!-----------------------------------------------------------------------
1074!
1075# ifdef DISTRIBUTE
1076!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
1077!^ & LBi, UBi, LBj, UBj, &
1078!^ & NghostPoints, &
1079!^ & EWperiodic(ng), NSperiodic(ng), &
1080!^ & tl_DU_flux, tl_DV_flux)
1081!^
1082 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
1083 & lbi, ubi, lbj, ubj, &
1084 & nghostpoints, &
1085 & ewperiodic(ng), nsperiodic(ng), &
1086 & ad_du_flux, ad_dv_flux)
1087!
1088# endif
1089 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1090!^ CALL exchange_v2d_tile (ng, tile, &
1091!^ & LBi, UBi, LBj, UBj, &
1092!^ & tl_DV_flux)
1093!^
1094 CALL ad_exchange_v2d_tile (ng, tile, &
1095 & lbi, ubi, lbj, ubj, &
1096 & ad_dv_flux)
1097!^ CALL exchange_u2d_tile (ng, tile, &
1098!^ & LBi, UBi, LBj, UBj, &
1099!^ & tl_DU_flux)
1100!^
1101 CALL ad_exchange_u2d_tile (ng, tile, &
1102 & lbi, ubi, lbj, ubj, &
1103 & ad_du_flux)
1104 END IF
1105#endif
1106
1107#ifdef SOLVE3D
1108!
1109!-----------------------------------------------------------------------
1110! Adjoint of finalize computation of barotropic mode averages.
1111!-----------------------------------------------------------------------
1112!
1113! This procedure starts with filling in boundary rows of total depths
1114! at the new time step, which is needed to be done only during the
1115! last barotropic time step, Normally, the computation of averages
1116! occurs at the beginning of the next predictor step because "DUon"
1117! and "DVom" are being computed anyway. Strictly speaking, the filling
1118! the boundaries are necessary only in the case of open boundaries,
1119! otherwise, the associated fluxes are all zeros.
1120!
1121 IF ((iif(ng).eq.nfast(ng)).and.(knew.lt.3)) THEN
1122# ifdef NESTING
1123!
1124! After all fast time steps are completed, apply boundary conditions
1125! to time averaged fields.
1126!
1127! In nesting applications with refinement grids, we need to exchange
1128! the DU_avg2 and DV_avg2 fluxes boundary information for the case
1129! that a contact point is at a tile partition. Notice that in such
1130! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
1131!
1132# ifdef DISTRIBUTE
1133!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
1134!^ & LBi, UBi, LBj, UBj, &
1135!^ & NghostPoints, &
1136!^ & EWperiodic(ng), NSperiodic(ng), &
1137!^ & tl_DU_avg2, tl_DV_avg2)
1138!^
1139 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
1140 & lbi, ubi, lbj, ubj, &
1141 & nghostpoints, &
1142 & ewperiodic(ng), nsperiodic(ng), &
1143 & ad_du_avg2, ad_dv_avg2)
1144!^ CALL mp_exchange2d (ng, tile, iTLM, 3, &
1145!^ & LBi, UBi, LBj, UBj, &
1146!^ & NghostPoints, &
1147!^ & EWperiodic(ng), NSperiodic(ng), &
1148!^ & tl_Zt_avg1, tl_DU_avg1, tl_DV_avg1)
1149!^
1150 CALL ad_mp_exchange2d (ng, tile, iadm, 3, &
1151 & lbi, ubi, lbj, ubj, &
1152 & nghostpoints, &
1153 & ewperiodic(ng), nsperiodic(ng), &
1154 & ad_zt_avg1, ad_du_avg1, ad_dv_avg1)
1155!
1156# endif
1157 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1158!^ CALL exchange_v2d_tile (ng, tile, &
1159!^ & LBi, UBi, LBj, UBj, &
1160!^ & tl_DV_avg2)
1161!^
1162 CALL ad_exchange_v2d_tile (ng, tile, &
1163 & lbi, ubi, lbj, ubj, &
1164 & ad_dv_avg2)
1165!^ CALL exchange_u2d_tile (ng, tile, &
1166!^ & LBi, UBi, LBj, UBj, &
1167!^ & tl_DU_avg2)
1168!^
1169 CALL ad_exchange_u2d_tile (ng, tile, &
1170 & lbi, ubi, lbj, ubj, &
1171 & ad_du_avg2)
1172!^ CALL exchange_v2d_tile (ng, tile, &
1173!^ & LBi, UBi, LBj, UBj, &
1174!^ & tl_DV_avg1)
1175!^
1176 CALL ad_exchange_v2d_tile (ng, tile, &
1177 & lbi, ubi, lbj, ubj, &
1178 & ad_dv_avg1)
1179!^ CALL exchange_u2d_tile (ng, tile, &
1180!^ & LBi, UBi, LBj, UBj, &
1181!^ & tl_DU_avg1)
1182!^
1183 CALL ad_exchange_u2d_tile (ng, tile, &
1184 & lbi, ubi, lbj, ubj, &
1185 & ad_du_avg1)
1186!^ CALL exchange_r2d_tile (ng, tile, &
1187!^ & LBi, UBi, LBj, UBj, &
1188!^ & tl_Zt_avg1)
1189!^
1190 CALL ad_exchange_r2d_tile (ng, tile, &
1191 & lbi, ubi, lbj, ubj, &
1192 & ad_zt_avg1)
1193 END IF
1194# endif
1195!
1196! Adjoint of end of the last 2D time step that replaces the new
1197! free-surface zeta(:,:,knew) with it fast time-averaged value,
1198! Zt_avg1. Recall this is state variable is the one that communicates
1199! with the 3D kernel. Then, compute time-dependent depths.
1200!
1201 cff=weight(1,iif(ng),ng)
1202 cff1=0.5*cff
1203!
1204!^ CALL tl_set_depth (ng, tile, iTLM)
1205!^
1206 CALL ad_set_depth (ng, tile, iadm)
1207!
1208 DO j=jstrr,jendr
1209 DO i=istrr,iendr
1210!^ tl_zeta(i,j,knew)=tl_Zt_avg1(i,j)
1211!^
1212 ad_zt_avg1(i,j)=ad_zt_avg1(i,j)+ad_zeta(i,j,knew)
1213 ad_zeta(i,j,knew)=0.0_r8
1214 IF (j.ge.jstr) THEN
1215!^ tl_DV_avg1(i,j)=tl_DV_avg1(i,j)+ &
1216!^ & cff1*om_v(i,j)* &
1217!^ & ((Dnew(i,j)+Dnew(i,j-1))* &
1218!^ & tl_vbar(i,j,knew)+ &
1219!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))* &
1220!^ & vbar(i,j,knew))
1221!^
1222 adfac=cff1*om_v(i,j)*ad_dv_avg1(i,j)
1223 adfac1=adfac*vbar(i,j,knew)
1224 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1225 & (dnew(i,j)+dnew(i,j-1))*adfac
1226 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1227 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1228 END IF
1229 IF (i.ge.istr) THEN
1230!^ tl_DU_avg1(i,j)=tl_DU_avg1(i,j)+ &
1231!^ & cff1*on_u(i,j)* &
1232!^ & ((Dnew(i,j)+Dnew(i-1,j))* &
1233!^ & tl_ubar(i,j,knew)+ &
1234!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))* &
1235!^ & ubar(i,j,knew))
1236!^
1237 adfac=cff1*on_u(i,j)*ad_du_avg1(i,j)
1238 adfac1=adfac*ubar(i,j,knew)
1239 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1240 & (dnew(i,j)+dnew(i-1,j))*adfac
1241 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1242 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1243 END IF
1244!^ tl_Zt_avg1(i,j)=tl_Zt_avg1(i,j)+ &
1245!^ & cff*tl_zeta(i,j,knew)
1246!^
1247 ad_zeta(i,j,knew)=ad_zeta(i,j,knew)+cff*ad_zt_avg1(i,j)
1248 END DO
1249 END DO
1250!
1251 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1252 IF (domain(ng)%Northern_Edge(tile)) THEN
1253 DO i=istr-1,iendr
1254!^ tl_Dnew(i,Jend+1)=tl_h(i,Jend+1)+tl_zeta_new(i,Jend+1)
1255!^
1256 ad_h(i,jend+1)=ad_h(i,jend+1)+ &
1257 & ad_dnew(i,jend+1)
1258 ad_zeta_new(i,jend+1)=ad_zeta_new(i,jend+1)+ &
1259 & ad_dnew(i,jend+1)
1260 ad_dnew(i,jend+1)=0.0_r8
1261 END DO
1262 END IF
1263 END IF
1264 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1265 IF (domain(ng)%Southern_Edge(tile)) THEN
1266 DO i=istr-1,iendr
1267!^ tl_Dnew(i,Jstr-1)=tl_h(i,Jstr-1)+tl_zeta_new(i,Jstr-1)
1268!^
1269 ad_h(i,jstr-1)=ad_h(i,jstr-1)+ &
1270 & ad_dnew(i,jstr-1)
1271 ad_zeta_new(i,jstr-1)=ad_zeta_new(i,jstr-1)+ &
1272 & ad_dnew(i,jstr-1)
1273 ad_dnew(i,jstr-1)=0.0_r8
1274 END DO
1275 END IF
1276 END IF
1277 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1278 IF (domain(ng)%Eastern_Edge(tile)) THEN
1279 DO j=jstr-1,jendr
1280!^ tl_Dnew(Iend+1,j)=tl_h(Iend+1,j)+tl_zeta_new(Iend+1,j)
1281!^
1282 ad_h(iend+1,j)=ad_h(iend+1,j)+ &
1283 & ad_dnew(iend+1,j)
1284 ad_zeta_new(iend+1,j)=ad_zeta_new(iend+1,j)+ &
1285 & ad_dnew(iend+1,j)
1286 ad_dnew(iend+1,j)=0.0_r8
1287 END DO
1288 END IF
1289 END IF
1290 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1291 IF (domain(ng)%Western_Edge(tile)) THEN
1292 DO j=jstr-1,jendr
1293!^ tl_Dnew(Istr-1,j)=tl_h(Istr-1,j)+tl_zeta_new(Istr-1,j)
1294!^
1295 ad_h(istr-1,j)=ad_h(istr-1,j)+ &
1296 & ad_dnew(istr-1,j)
1297 ad_zeta_new(istr-1,j)=ad_zeta_new(istr-1,j)+ &
1298 & ad_dnew(istr-1,j)
1299 ad_dnew(istr-1,j)=0.0_r8
1300 END DO
1301 END IF
1302 END IF
1303 END IF
1304#endif
1305!
1306!-----------------------------------------------------------------------
1307! Apply momentum transport point sources (like river runoff), if any.
1308!
1309! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
1310! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
1311!-----------------------------------------------------------------------
1312!
1313 IF (luvsrc(ng)) THEN
1314 DO is=1,nsrc(ng)
1315 i=sources(ng)%Isrc(is)
1316 j=sources(ng)%Jsrc(is)
1317 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1318 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1319 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
1320 cff=1.0_r8/(on_u(i,j)* &
1321 & 0.5_r8*(dnew(i-1,j)+dnew(i,j)))
1322#if defined NESTING && !defined SOLVE3D
1323!^ tl_DU_flux(i,j)=SOURCES(ng)%tl_Qbar(is)
1324!^
1325 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1326 & ad_du_flux(i,j)
1327 ad_du_flux(i,j)=0.0_r8
1328#endif
1329#ifdef SOLVE3D
1330!^ tl_DU_avg1(i,j)=SOURCES(ng)%tl_Qbar(is)
1331!^
1332 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1333 & ad_du_avg1(i,j)
1334 ad_du_avg1(i,j)=0.0_r8
1335#endif
1336!^ tl_ubar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
1337!^ & SOURCES(ng)%Qbar(is)*tl_cff
1338!^
1339 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1340 & cff*ad_ubar(i,j,knew)
1341 ad_cff=ad_cff+ &
1342 & sources(ng)%Qbar(is)*ad_ubar(i,j,knew)
1343
1344 ad_ubar(i,j,knew)=0.0_r8
1345!^ tl_cff=-cff*cff*on_u(i,j)* &
1346!^ & 0.5_r8*(tl_Dnew(i-1,j)+tl_Dnew(i ,j))
1347!^
1348 adfac=-cff*cff*on_u(i,j)*0.5_r8*ad_cff
1349 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1350 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1351 ad_cff=0.0_r8
1352 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
1353 cff=1.0_r8/(om_v(i,j)* &
1354 & 0.5_r8*(dnew(i,j-1)+dnew(i,j)))
1355#if defined NESTING && !defined SOLVE3D
1356!^ tl_DV_flux(i,j)=SOURCES(ng)%tl_Qbar(is)
1357!^
1358 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1359 & ad_dv_flux(i,j)
1360 ad_dv_flux(i,j)=0.0_r8
1361#endif
1362#ifdef SOLVE3D
1363!^ tl_DV_avg1(i,j)=SOURCES(ng)%tl_Qbar(is)
1364!^
1365 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1366 & ad_dv_avg1(i,j)
1367 ad_dv_avg1(i,j)=0.0_r8
1368#endif
1369!^ tl_vbar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
1370!^ & SOURCES(ng)%Qbar(is)*tl_cff
1371!^
1372 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1373 & cff*ad_vbar(i,j,knew)
1374 ad_cff=ad_cff+ &
1375 & sources(ng)%Qbar(is)*ad_vbar(i,j,knew)
1376 ad_vbar(i,j,knew)=0.0_r8
1377!^ tl_cff=-cff*cff*om_v(i,j)* &
1378!^ & 0.5_r8*(tl_Dnew(i,j-1)+tl_Dnew(i,j))
1379!^
1380 adfac=-cff*cff*om_v(i,j)*0.5_r8*ad_cff
1381 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1382 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1383 ad_cff=0.0_r8
1384 END IF
1385 END IF
1386 END DO
1387 END IF
1388
1389#if defined NESTING && !defined SOLVE3D
1390!
1391! Set adjoint barotropic fluxes along physical boundaries.
1392!
1393 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1394 IF (domain(ng)%Northern_Edge(tile)) THEN
1395 DO i=istrr,iendr
1396!^ tl_DV_flux(i,Jend+1)=0.5_r8*om_v(i,Jend+1)* &
1397!^ & ((Dnew(i,Jend+1)+ &
1398!^ & Dnew(i,Jend ))* &
1399!^ & tl_vbar(i,Jend+1,knew)+ &
1400!^ & (tl_Dnew(i,Jend+1)+ &
1401!^ & tl_Dnew(i,Jend ))* &
1402!^ & vbar(i,Jend+1,knew))
1403!^
1404 adfac=0.5_r8*om_v(i,jend+1)*ad_dv_flux(i,jend+1)
1405 adfac1=adfac1*vbar(i,jend+1,knew)
1406 ad_vbar(i,jend+1,knew)=ad_vbar(i,jend+1,knew)+ &
1407 & (dnew(i,jend+1)+ &
1408 & dnew(i,jend ))*adfac
1409 ad_dnew(i,jend )=ad_dnew(i,jend )+adfac1
1410 ad_dnew(i,jend+1)=ad_dnew(i,jend+1)+adfac1
1411 ad_dv_flux(i,jend+1)=0.0_r8
1412 END DO
1413 DO i=istru,iend
1414!^ tl_DU_flux(i,Jend+1)=0.5_r8*on_u(i,Jend+1)* &
1415!^ & ((Dnew(i ,Jend+1)+ &
1416!^ & Dnew(i-1,Jend+1))* &
1417!^ & tl_ubar(i,Jend+1,knew)+ &
1418!^ & (tl_Dnew(i ,Jend+1)+ &
1419!^ & tl_Dnew(i-1,Jend+1))* &
1420!^ & ubar(i,Jend+1,knew))
1421!^
1422 adfac=0.5_r8*on_u(i,jend+1)*ad_du_flux(i,jend+1)
1423 adfac1=adfac*ubar(i,jend+1,knew)
1424 ad_ubar(i,jend+1,knew)=ad_ubar(i,jend+1,knew)+ &
1425 & (dnew(i ,jend+1)+ &
1426 & dnew(i-1,jend+1))*adfac
1427 ad_dnew(i-1,jend+1)=ad_dnew(i-1,jend+1)+adfac1
1428 ad_dnew(i ,jend+1)=ad_dnew(i ,jend+1)+adfac1
1429 ad_du_flux(i,jend+1)=0.0_r8
1430 END DO
1431 END IF
1432 END IF
1433
1434 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1435 IF (domain(ng)%Southern_Edge(tile)) THEN
1436 DO i=istrr,iendr
1437!^ tl_DV_flux(i,JstrV-1)=0.5_r8*om_v(i,JstrV-1)* &
1438!^ & ((Dnew(i,JstrV-1)+ &
1439!^ & Dnew(i,JstrV-2))* &
1440!^ & tl_vbar(i,JstrV-1,knew)+ &
1441!^ & (tl_Dnew(i,JstrV-1)+ &
1442!^ & tl_Dnew(i,JstrV-2))* &
1443!^ & vbar(i,JstrV-1,knew))
1444!^
1445 adfac=0.5_r8*om_v(i,jstrv-1)*ad_dv_flux(i,jstrv-1)
1446 adfac1=adfac*vbar(i,jstrv-1,knew)
1447 ad_vbar(i,jstrv-1,knew)=ad_vbar(i,jstrv-1,knew)+ &
1448 & (dnew(i,jstrv-1)+ &
1449 & dnew(i,jstrv-2))*adfac
1450 ad_dnew(i,jstrv-2)=ad_dnew(i,jstrv-2)+adfac1
1451 ad_dnew(i,jstrv-1)=ad_dnew(i,jstrv-1)+adfac1
1452 ad_dv_flux(i,jstrv-1)=0.0_r8
1453 END DO
1454 DO i=istru,iend
1455!^ tl_DU_flux(i,Jstr-1)=0.5_r8*on_u(i,Jstr-1)* &
1456!^ & ((Dnew(i ,Jstr-1)+ &
1457!^ & Dnew(i-1,Jstr-1))* &
1458!^ & tl_ubar(i,Jstr-1,knew)+ &
1459!^ & (tl_Dnew(i ,Jstr-1)+ &
1460!^ & tl_Dnew(i-1,Jstr-1))* &
1461!^ & ubar(i,Jstr-1,knew))
1462!^
1463 adfac=0.5_r8*on_u(i,jstr-1)*ad_du_flux(i,jstr-1)
1464 adfac1=adfac*ubar(i,jstr-1,knew)
1465 ad_ubar(i,jstr-1,knew)=ad_ubar(i,jstr-1,knew)+ &
1466 & (dnew(i ,jstr-1)+ &
1467 & dnew(i-1,jstr-1))*adfac
1468 ad_dnew(i-1,jstr-1)=ad_dnew(i-1,jstr-1)+adfac1
1469 ad_dnew(i ,jstr-1)=ad_dnew(i ,jstr-1)+adfac1
1470 ad_du_flux(i,jstr-1)=0.0_r8
1471 END DO
1472 END IF
1473 END IF
1474
1475 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1476 IF (domain(ng)%Eastern_Edge(tile)) THEN
1477 DO j=jstrv,jend
1478!^ tl_DV_flux(Iend+1,j)=0.5_r8*om_v(Iend+1,j)* &
1479!^ & ((Dnew(Iend+1,j )+ &
1480!^ & Dnew(Iend+1,j-1))* &
1481!^ & tl_vbar(Iend+1,j,knew)+ &
1482!^ & (tl_Dnew(Iend+1,j )+ &
1483!^ & tl_Dnew(Iend+1,j-1))* &
1484!^ & vbar(Iend+1,j,knew))
1485!^
1486 adfac=0.5_r8*om_v(iend+1,j)*ad_dv_flux(iend+1,j)
1487 adfac1=adfac*vbar(iend+1,j,knew)
1488 ad_vbar(iend+1,j,knew)=ad_vbar(iend+1,j,knew)+ &
1489 & (dnew(iend+1,j )+ &
1490 & dnew(iend+1,j-1))*adfac
1491 ad_dnew(iend+1,j-1)=ad_dnew(iend+1,j-1)+adfac1
1492 ad_dnew(iend+1,j )=ad_dnew(iend+1,j )+adfac1
1493 ad_dv_flux(iend+1,j)=0.0_r8
1494 END DO
1495 DO j=jstrr,jendr
1496!^ tl_DU_flux(Iend+1,j)=0.5_r8*on_u(Iend+1,j)* &
1497!^ & ((Dnew(Iend+1,j)+ &
1498!^ & Dnew(Iend ,j))* &
1499!^ & tl_ubar(Iend+1,j,knew)+ &
1500!^ & (tl_Dnew(Iend+1,j)+ &
1501!^ & tl_Dnew(Iend ,j))* &
1502!^ & ubar(Iend+1,j,knew))
1503!^
1504 adfac=0.5_r8*on_u(iend+1,j)*ad_du_flux(iend+1,j)
1505 adfac1=adfac*ubar(iend+1,j,knew)
1506 ad_ubar(iend+1,j,knew)=ad_ubar(iend+1,j,knew)+ &
1507 & (dnew(iend+1,j)+ &
1508 & dnew(iend ,j))*adfac
1509 ad_dnew(iend ,j)=ad_dnew(iend ,j)+adfac1
1510 ad_dnew(iend+1,j)=ad_dnew(iend+1,j)+adfac1
1511 ad_du_flux(iend+1,j)=0.0_r8
1512 END DO
1513 END IF
1514 END IF
1515
1516 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1517 IF (domain(ng)%Western_Edge(tile)) THEN
1518 DO j=jstrv,jend
1519!^ tl_DV_flux(Istr-1,j)=0.5_r8*om_v(Istr-1,j)* &
1520!^ & ((Dnew(Istr-1,j )+ &
1521!^ & Dnew(Istr-1,j-1))* &
1522!^ & tl_vbar(Istr-1,j,knew)+ &
1523!^ & (tl_Dnew(Istr-1,j )+ &
1524!^ & tl_Dnew(Istr-1,j-1))* &
1525!^ & vbar(Istr-1,j,knew))
1526!^
1527 adfac=0.5_r8*om_v(istr-1,j)*ad_dv_flux(istr-1,j)
1528 adfac1=adfac*vbar(istr-1,j,knew)
1529 ad_vbar(istr-1,j,knew)=ad_vbar(istr-1,j,knew)+ &
1530 & (dnew(istr-1,j )+ &
1531 & dnew(istr-1,j-1))*adfac
1532 ad_dnew(istr-1,j-1)=ad_dnew(istr-1,j-1)+adfac1
1533 ad_dnew(istr-1,j )=ad_dnew(istr-1,j )+adfac1
1534 ad_dv_flux(istr-1,j)=0.0_r8
1535 END DO
1536 DO j=jstrr,jendr
1537!^ tl_DU_flux(IstrU-1,j)=0.5_r8*on_u(IstrU-1,j)* &
1538!^ & ((Dnew(IstrU-1,j)+ &
1539!^ & Dnew(IstrU-2,j))* &
1540!^ & tl_ubar(IstrU-1,j,knew)+ &
1541!^ & (tl_Dnew(IstrU-1,j)+ &
1542!^ & tl_Dnew(IstrU-2,j))* &
1543!^ & ubar(IstrU-1,j,knew))
1544!^
1545 adfac=0.5_r8*on_u(istru-1,j)*ad_du_flux(istru-1,j)
1546 adfac1=adfac*ubar(istru-1,j,knew)
1547 ad_ubar(istru-1,j,knew)=ad_ubar(istru-1,j,knew)+ &
1548 & (dnew(istru-1,j)+ &
1549 & dnew(istru-2,j))*adfac
1550 ad_dnew(istru-2,j)=ad_dnew(istru-2,j)+adfac1
1551 ad_dnew(istru-1,j)=ad_dnew(istru-1,j)+adfac1
1552 ad_du_flux(istru-1,j)=0.0_r8
1553 END DO
1554 END IF
1555 END IF
1556!
1557 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1558 IF (domain(ng)%Northern_Edge(tile)) THEN
1559 DO i=istr-1,iendr
1560!^ tl_Dnew(i,Jend+1)=tl_h(i,Jend+1)+tl_zeta_new(i,Jend+1)
1561!^
1562 ad_h(i,jend+1)=ad_h(i,jend+1)+ &
1563 & ad_dnew(i,jend+1)
1564 ad_zeta_new(i,jend+1)=ad_zeta_new(i,jend+1)+ &
1565 & ad_dnew(i,jend+1)
1566 ad_dnew(i,jend+1)=0.0_r8
1567 END DO
1568 END IF
1569 END IF
1570 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1571 IF (domain(ng)%Southern_Edge(tile)) THEN
1572 DO i=istr-1,iendr
1573!^ tl_Dnew(i,Jstr-1)=tl_h(i,Jstr-1)+tl_zeta_new(i,Jstr-1)
1574!^
1575 ad_h(i,jstr-1)=ad_h(i,jstr-1)+ &
1576 & ad_dnew(i,jstr-1)
1577 ad_zeta_new(i,jstr-1)=ad_zeta_new(i,jstr-1)+ &
1578 & ad_dnew(i,jstr-1)
1579 ad_dnew(i,jstr-1)=0.0_r8
1580 END DO
1581 END IF
1582 END IF
1583 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1584 IF (domain(ng)%Eastern_Edge(tile)) THEN
1585 DO j=jstr-1,jendr
1586!^ tl_Dnew(Iend+1,j)=tl_h(Iend+1,j)+tl_zeta_new(Iend+1,j)
1587!^
1588 ad_h(iend+1,j)=ad_h(iend+1,j)+ &
1589 & ad_dnew(iend+1,j)
1590 ad_zeta_new(iend+1,j)=ad_zeta_new(iend+1,j)+ &
1591 & ad_dnew(iend+1,j)
1592 ad_dnew(iend+1,j)=0.0_r8
1593 END DO
1594 END IF
1595 END IF
1596 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1597 IF (domain(ng)%Western_Edge(tile)) THEN
1598 DO j=jstr-1,jendr
1599!^ tl_Dnew(Istr-1,j)=tl_h(Istr-1,j)+tl_zeta_new(Istr-1,j)
1600!^
1601 ad_h(istr-1,j)=ad_h(istr-1,j)+ &
1602 & ad_dnew(istr-1,j)
1603 ad_zeta_new(istr-1,j)=ad_zeta_new(istr-1,j)+ &
1604 & ad_dnew(istr-1,j)
1605 ad_dnew(istr-1,j)=0.0_r8
1606 END DO
1607 END IF
1608 END IF
1609#endif
1610!
1611!=======================================================================
1612! Adjoint of time step 2D momentum equations.
1613!=======================================================================
1614!
1615! Compute integral mass flux across open boundaries and adjust
1616! for volume conservation.
1617!
1618 IF (any(volcons(:,ng))) THEN
1619!^ CALL tl_obc_flux_tile (ng, tile, &
1620!^ & LBi, UBi, LBj, UBj, &
1621!^ & IminS, ImaxS, JminS, JmaxS, &
1622!^ & knew, &
1623#ifdef MASKING
1624!^ & umask, vmask, &
1625#endif
1626!^ & h, tl_h, om_v, on_u, &
1627!^ & ubar, vbar, zeta, &
1628!^ & tl_ubar, tl_vbar, tl_zeta)
1629!^
1630 CALL ad_obc_flux_tile (ng, tile, &
1631 & lbi, ubi, lbj, ubj, &
1632 & imins, imaxs, jmins, jmaxs, &
1633 & knew, &
1634#ifdef MASKING
1635 & umask, vmask, &
1636#endif
1637 & h, ad_h, om_v, on_u, &
1638 & ubar, vbar, zeta, &
1639 & ad_ubar, ad_vbar, ad_zeta)
1640 END IF
1641!
1642! Apply lateral boundary conditions.
1643!
1644!^ CALL tl_v2dbc_tile (ng, tile, &
1645!^ & LBi, UBi, LBj, UBj, &
1646!^ & IminS, ImaxS, JminS, JmaxS, &
1647!^ & krhs, kstp, knew, &
1648!^ & ubar, vbar, zeta, &
1649!^ & tl_ubar, tl_vbar, tl_zeta)
1650!^
1651 CALL ad_v2dbc_tile (ng, tile, &
1652 & lbi, ubi, lbj, ubj, &
1653 & imins, imaxs, jmins, jmaxs, &
1654 & krhs, kstp, knew, &
1655 & ubar, vbar, zeta, &
1656 & ad_ubar, ad_vbar, ad_zeta)
1657!^ CALL tl_u2dbc_tile (ng, tile, &
1658!^ & LBi, UBi, LBj, UBj, &
1659!^ & IminS, ImaxS, JminS, JmaxS, &
1660!^ & krhs, kstp, knew, &
1661!^ & ubar, vbar, zeta, &
1662!^ & tl_ubar, tl_vbar, tl_zeta)
1663!^
1664 CALL ad_u2dbc_tile (ng, tile, &
1665 & lbi, ubi, lbj, ubj, &
1666 & imins, imaxs, jmins, jmaxs, &
1667 & krhs, kstp, knew, &
1668 & ubar, vbar, zeta, &
1669 & ad_ubar, ad_vbar, ad_zeta)
1670!
1671! During the predictor sub-step, once newly computed "ubar" and "vbar"
1672! become available, interpolate them half-step backward in barotropic
1673! time (i.e., they end up time-centered at n+1/2) in order to use it
1674! during subsequent corrector sub-step.
1675!
1676 IF (predictor_2d_step) THEN
1677 IF (first_2d_step) THEN
1678 cff1=0.5_r8*dtfast(ng)
1679 cff2=0.5_r8
1680 cff3=0.5_r8
1681 cff4=0.0_r8
1682 ELSE
1683 cff1=dtfast(ng)
1684 cff2=0.5_r8-gamma
1685 cff3=0.5_r8+2.0_r8*gamma
1686 cff4=-gamma
1687 ENDIF
1688
1689 DO j=jstrv,jend
1690 DO i=istr,iend
1691 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1692 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
1693#if defined NESTING && !defined SOLVE3D
1694!^ tl_DV_flux(i,j)=0.5_r8*om_v(i,j)* &
1695!^ & ((Dnew(i,j)+Dnew(i,j-1))* &
1696!^ & tl_vbar(i,j,knew)+ &
1697!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))* &
1698!^ & vbar(i,j,knew))
1699!^
1700 adfac=0.5_r8*om_v(i,j)*ad_dv_flux(i,j)
1701 adfac1=adfac*vbar(i,j,knew)
1702 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1703 & (dnew(i,j)+dnew(i,j-1))*adfac
1704 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1705 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1706 ad_dv_flux(i,j)=0.0_r8
1707#endif
1708#ifdef WET_DRY_NOT_YET
1709!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1710!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1711!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1712!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1713!^
1714!^ HGA: TLM code needed here.
1715!^
1716#endif
1717!^ tl_vbar(i,j,knew)=cff2*tl_vbar(i,j,knew)+ &
1718!^ & cff3*tl_vbar(i,j,kstp)+ &
1719!^ & cff4*tl_vbar(i,j,kbak)
1720!^
1721 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+cff2*ad_vbar(i,j,knew)
1722 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+cff3*ad_vbar(i,j,knew)
1723 ad_vbar(i,j,kbak)=ad_vbar(i,j,kbak)+cff4*ad_vbar(i,j,knew)
1724 ad_vbar(i,j,knew)=0.0_r8
1725#ifdef MASKING
1726!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1727!^
1728 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1729#endif
1730!^ tl_vbar(i,j,knew)=tl_fac2* &
1731!^ & (vbar(i,j,kbak)* &
1732!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1733#ifdef SOLVE3D
1734!^ & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
1735#else
1736!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
1737#endif
1738!^ & fac2* &
1739!^ & (tl_vbar(i,j,kbak)* &
1740!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1741!^ & vbar(i,j,kbak)* &
1742!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))+ &
1743#ifdef SOLVE3D
1744!^ & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
1745#else
1746!^ & cff*tl_rvbar(i,j)+ &
1747!^ & 4.0_r8*cff1*tl_svstr(i,j))
1748#endif
1749!^
1750 adfac=fac2*ad_vbar(i,j,knew)
1751 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1752 adfac2=adfac*cff
1753 adfac3=adfac*vbar(i,j,kbak)
1754 ad_vbar(i,j,kbak)=ad_vbar(i,j,kbak)+adfac1
1755#ifdef SOLVE3D
1756 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1757 ad_rvfrc(i,j)=ad_rvfrc(i,j)+adfac2
1758#else
1759 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1760 ad_svstr(i,j)=ad_svstr(i,j)+4.0_r8*cff1*adfac
1761#endif
1762 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1763 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1764 ad_fac2=ad_fac2+ &
1765 & ad_vbar(i,j,knew)* &
1766 & (vbar(i,j,kbak)* &
1767 & (dstp(i,j)+dstp(i,j-1))+ &
1768#ifdef SOLVE3D
1769 & cff*(rvbar(i,j)+rvfrc(i,j)))
1770#else
1771 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
1772#endif
1773 ad_vbar(i,j,knew)=0.0_r8
1774!^ tl_fac2=-fac2*fac2*(tl_Dnew(i,j)+tl_Dnew(i,j-1))
1775!^
1776 adfac=-fac2*fac2*ad_fac2
1777 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1778 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1779 ad_fac2=0.0_r8
1780 END DO
1781 END DO
1782!
1783 DO j=jstr,jend
1784 DO i=istru,iend
1785 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1786 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
1787#if defined NESTING && !defined SOLVE3D
1788!^ tl_DU_flux(i,j)=0.5_r8*on_u(i,j)* &
1789!^ & ((Dnew(i,j)+Dnew(i-1,j))* &
1790!^ & tl_ubar(i,j,knew)+ &
1791!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))* &
1792!^ & ubar(i,j,knew))
1793!^
1794 adfac=0.5_r8*on_u(i,j)*ad_du_flux(i,j)
1795 adfac1=adfac*ubar(i,j,knew)
1796 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1797 & (dnew(i,j)+dnew(i-1,j))*adfac
1798 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1799 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1800 ad_du_flux(i,j)=0.0_r8
1801#endif
1802#ifdef WET_DRY_NOT_YET
1803!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1804!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1805!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1806!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1807!^
1808!^ HGA: TLM code needed here.
1809!^
1810#endif
1811!^ tl_ubar(i,j,knew)=cff2*tl_ubar(i,j,knew)+ &
1812!^ & cff3*tl_ubar(i,j,kstp)+ &
1813!^ & cff4*tl_ubar(i,j,kbak)
1814!^
1815 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+cff2*ad_ubar(i,j,knew)
1816 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+cff3*ad_ubar(i,j,knew)
1817 ad_ubar(i,j,kbak)=ad_ubar(i,j,kbak)+cff4*ad_ubar(i,j,knew)
1818 ad_ubar(i,j,knew)=0.0_r8
1819#ifdef MASKING
1820!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1821!^
1822 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1823#endif
1824!^ tl_ubar(i,j,knew)=tl_fac1* &
1825!^ & (ubar(i,j,kbak)* &
1826!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1827#ifdef SOLVE3D
1828!^ & cff*(rubar(i,j)+rufrc(i,j)))+ &
1829#else
1830!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
1831#endif
1832!^ & fac1* &
1833!^ & (tl_ubar(i,j,kbak)* &
1834!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
1835!^ & ubar(i,j,kbak)* &
1836!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))+ &
1837#ifdef SOLVE3D
1838!^ & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))
1839#else
1840!^ & cff*tl_rubar(i,j)+ &
1841!^ & 4.0_r8*cff1*tl_sustr(i,j))
1842#endif
1843!^
1844 adfac=fac1*ad_ubar(i,j,knew)
1845 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
1846 adfac2=adfac*cff
1847 adfac3=adfac*ubar(i,j,kbak)
1848 ad_ubar(i,j,kbak)=ad_ubar(i,j,kbak)+adfac1
1849#ifdef SOLVE3D
1850 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
1851 ad_rufrc(i,j)=ad_rufrc(i,j)+adfac2
1852#else
1853 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
1854 ad_sustr(i,j)=ad_sustr(i,j)+4.0_r8*cff1*adfac
1855#endif
1856 ad_fac1=ad_fac1+ &
1857 & ad_ubar(i,j,knew)* &
1858 & (ubar(i,j,kbak)* &
1859 & (dstp(i,j)+dstp(i-1,j))+ &
1860#ifdef SOLVE3D
1861 & cff*(rubar(i,j)+rufrc(i,j)))
1862#else
1863 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
1864#endif
1865 ad_ubar(i,j,knew)=0.0_r8
1866!^ tl_fac1=-fac1*fac1*(tl_Dnew(i,j)+tl_Dnew(i-1,j))
1867!^
1868 adfac=-fac1*fac1*ad_fac1
1869 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1870 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1871 ad_fac1=0.0_r8
1872 END DO
1873 END DO
1874
1875 ELSE !--> CORRECTOR_2D_STEP
1876
1877 DO j=jstrv,jend
1878 DO i=istr,iend
1879 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1880 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
1881#if defined NESTING && !defined SOLVE3D
1882!^ tl_DV_flux(i,j)=0.5_r8*om_v(i,j)* &
1883!^ & ((Dnew(i,j)+Dnew(i,j-1))* &
1884!^ & tl_vbar(i,j,knew)+ &
1885!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))* &
1886!^ & vbar(i,j,knew))
1887!^
1888 adfac=0.5_r8*om_v(i,j)*ad_dv_flux(i,j)
1889 adfac1=adfac*vbar(i,j,knew)
1890 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1891 & (dnew(i,j)+dnew(i,j-1))*adfac
1892 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1893 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1894 ad_dv_flux(i,j)=0.0_r8
1895#endif
1896#ifdef WET_DRY_NOT_YET
1897!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1898!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1899!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1900!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1901!^
1902!^ HGA: TLM code needed here.
1903!^
1904#endif
1905#ifdef MASKING
1906!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1907!^
1908 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1909#endif
1910!^ tl_vbar(i,j,knew)=tl_fac2* &
1911!^ & (vbar(i,j,kstp)* &
1912!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1913#ifdef SOLVE3D
1914!^ & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
1915#else
1916!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
1917#endif
1918!^ & fac2* &
1919!^ & (tl_vbar(i,j,kstp)* &
1920!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
1921!^ & vbar(i,j,kstp)* &
1922!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))+ &
1923#ifdef SOLVE3D
1924!^ & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
1925#else
1926!^ & cff*tl_rvbar(i,j)+ &
1927!^ & 4.0_r8*cff1*svstr(i,j))
1928#endif
1929!^
1930 adfac=fac2*ad_vbar(i,j,knew)
1931 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1932 adfac2=adfac*cff
1933 adfac3=adfac*vbar(i,j,kstp)
1934 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+adfac1
1935#ifdef SOLVE3D
1936 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1937 ad_rvfrc(i,j)=ad_rvfrc(i,j)+adfac2
1938#else
1939 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1940 ad_svstr(i,j)=ad_svstr(i,j)+4.0_r8*cff1*adfac
1941#endif
1942 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1943 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1944 ad_fac2=ad_fac2+ &
1945 & ad_vbar(i,j,knew)* &
1946 & (vbar(i,j,kstp)* &
1947 & (dstp(i,j)+dstp(i,j-1))+ &
1948#ifdef SOLVE3D
1949 & cff*(rvbar(i,j)+rvfrc(i,j)))
1950#else
1951 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
1952#endif
1953 ad_vbar(i,j,knew)=0.0_r8
1954!^ tl_fac2=-fac2*fac2*(tl_Dnew(i,j)+tl_Dnew(i,j-1))
1955!^
1956 adfac=-fac2*fac2*ad_fac2
1957 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1958 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1959 ad_fac2=0.0_r8
1960 END DO
1961 END DO
1962!
1963 cff1=0.5_r8*dtfast(ng)
1964 DO j=jstr,jend
1965 DO i=istru,iend
1966 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1967 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
1968#if defined NESTING && !defined SOLVE3D
1969!^ tl_DU_flux(i,j)=0.5_r8*on_u(i,j)* &
1970!^ & ((Dnew(i,j)+Dnew(i-1,j))* &
1971!^ & tl_ubar(i,j,knew)+ &
1972!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))* &
1973!^ & ubar(i,j,knew))
1974!^
1975 adfac=0.5_r8*on_u(i,j)*ad_du_flux(i,j)
1976 adfac1=adfac*ubar(i,j,knew)
1977 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1978 & (dnew(i,j)+dnew(i-1,j))*adfac
1979 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1980 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1981 ad_du_flux(i,j)=0.0_r8
1982#endif
1983#ifdef WET_DRY_NOT_YET
1984!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1985!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1986!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1987!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1988!^
1989!^ HGA: TLM code needed here.
1990!^
1991#endif
1992#ifdef MASKING
1993!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1994!^
1995 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1996#endif
1997!^ tl_ubar(i,j,knew)=tl_fac1* &
1998!^ & (ubar(i,j,kstp)* &
1999!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2000#ifdef SOLVE3D
2001!^ & cff*(rubar(i,j)+rufrc(i,j)))+ &
2002#else
2003!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
2004#endif
2005!^ & fac1* &
2006!^ & (tl_ubar(i,j,kstp)* &
2007!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2008!^ & ubar(i,j,kstp)* &
2009!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))+ &
2010#ifdef SOLVE3D
2011!^ & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))
2012#else
2013!^ & cff*tl_rubar(i,j)+ &
2014!^ & 4.0_r8*cff1*tl_sustr(i,j))
2015#endif
2016!^
2017 adfac=fac1*ad_ubar(i,j,knew)
2018 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
2019 adfac2=adfac*cff
2020 adfac3=adfac*ubar(i,j,kstp)
2021 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+adfac1
2022#ifdef SOLVE3D
2023 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
2024 ad_rufrc(i,j)=ad_rufrc(i,j)+adfac2
2025#else
2026 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
2027 ad_sustr(i,j)=ad_sustr(i,j)+4.0_r8*cff1*adfac
2028#endif
2029 ad_fac1=ad_fac1+ &
2030 & ad_ubar(i,j,knew)* &
2031 & (ubar(i,j,kstp)* &
2032 & (dstp(i,j)+dstp(i-1,j))+ &
2033#ifdef SOLVE3D
2034 & cff*(rubar(i,j)+rufrc(i,j)))
2035#else
2036 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
2037#endif
2038 ad_ubar(i,j,knew)=0.0_r8
2039!^ tl_fac1=-fac1*fac1*(Dnew(i,j)+Dnew(i-1,j))
2040!^
2041 adfac=-fac1*fac1*ad_fac1
2042 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
2043 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
2044 ad_fac1=0.0_r8
2045 END DO
2046 END DO
2047 END IF
2048!
2049! Compute total water column depth.
2050!
2051 IF (first_2d_step.or.(.not.predictor_2d_step)) THEN
2052 DO j=jstrv-1,jend
2053 DO i=istru-1,iend
2054!^ tl_Dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kstp)
2055!^
2056 ad_h(i,j)=ad_h(i,j)+ad_dstp(i,j)
2057 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_dstp(i,j)
2058 ad_dstp(i,j)=0.0_r8
2059 END DO
2060 END DO
2061 ELSE
2062 DO j=jstrv-1,jend
2063 DO i=istru-1,iend
2064!^ tl_Dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kbak)
2065!^
2066 ad_h(i,j)=ad_h(i,j)+ad_dstp(i,j)
2067 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+ad_dstp(i,j)
2068 ad_dstp(i,j)=0.0_r8
2069 END DO
2070 END DO
2071 END IF
2072
2073#ifdef SOLVE3D
2074!
2075!-----------------------------------------------------------------------
2076! Coupling between 2D and 3D equations.
2077!-----------------------------------------------------------------------
2078!
2079! Before the predictor step of the first barotropic time step, arrays
2080! "rufrc" and "rvfrc" contain vertical integrals of the 3D RHS terms
2081! for the momentum equations (including surface and bottom stresses,
2082! if so prescribed). During the first barotropic time step, convert
2083! them into forcing terms by subtracting the fast-time "rubar" and
2084! "rvbar" from them.
2085!
2086! These forcing terms are then extrapolated forward in time using
2087! optimized Adams-Bashforth weights, so that the resultant "rufrc"
2088! and "rvfrc" are centered effectively at time n+1/2 in baroclinic
2089! time.
2090!
2091! From now on, these newly computed forcing terms remain unchanged
2092! during the fast time stepping and will be added to "rubar" and
2093! "rvbar" during all subsequent barotropic time steps.
2094!
2095! Thus, the algorithm below is designed for coupling during the 3D
2096! predictor sub-step. The forcing terms "rufrc" and "rvfrc" are
2097! computed as instantaneous values at 3D time index "nstp" first and
2098! then extrapolated half-step forward using AM3-like weights optimized
2099! for maximum stability (with particular care for startup).
2100!
2101 IF (first_2d_step.and.predictor_2d_step) THEN
2102 IF (first_time_step) THEN
2103 cff3=0.0_r8
2104 cff2=0.0_r8
2105 cff1=1.0_r8
2106 ELSE IF (first_time_step+1) THEN
2107 cff3=0.0_r8
2108 cff2=-0.5_r8
2109 cff1=1.5_r8
2110 ELSE
2111 cff3=0.281105_r8
2112 cff2=-0.5_r8-2.0_r8*cff3
2113 cff1=1.5_r8+cff3
2114 END IF
2115!
2116 DO j=jstr,jend
2117 DO i=istr,iend
2118 IF (j.ge.jstrv) THEN
2119# ifdef DIAGNOSTICS_UV
2120!! DiaV2rhs(i,j,M2pgrd)=DiaV2rhs(i,j,M2pgrd)+ &
2121!! & rvbar(i,j)
2122# endif
2123!^ tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2124!^ & cff1*om_v(i,j)* &
2125!^ & ((tl_h(i,j-1)+ &
2126!^ & tl_h(i,j ))* &
2127!^ & (rzeta(i,j-1)- &
2128!^ & rzeta(i,j ))+ &
2129!^ & (h(i,j-1)+ &
2130!^ & h(i,j ))* &
2131!^ & (tl_rzeta(i,j-1)- &
2132!^ & tl_rzeta(i,j ))+ &
2133# if defined VAR_RHO_2D && defined SOLVE3D
2134!^ & (tl_h(i,j-1)- &
2135!^ & tl_h(i,j ))* &
2136!^ & (rzetaSA(i,j-1)+ &
2137!^ & rzetaSA(i,j )+ &
2138!^ & cff2*(rhoA(i,j-1)- &
2139!^ & rhoA(i,j ))* &
2140!^ & (zwrk(i,j-1)- &
2141!^ & zwrk(i,j )))+ &
2142!^ & (h(i,j-1)- &
2143!^ & h(i,j ))* &
2144!^ & (tl_rzetaSA(i,j-1)+ &
2145!^ & tl_rzetaSA(i,j )+ &
2146!^ & cff2*((tl_rhoA(i,j-1)- &
2147!^ & tl_rhoA(i,j ))* &
2148!^ & (zwrk(i,j-1)- &
2149!^ & zwrk(i,j ))+ &
2150!^ & (rhoA(i,j-1)- &
2151!^ & rhoA(i,j ))* &
2152!^ & (tl_zwrk(i,j-1)- &
2153!^ & tl_zwrk(i,j ))))+ &
2154# endif
2155!^ & (tl_rzeta2(i,j-1)- &
2156!^ & tl_rzeta2(i,j )))
2157!^
2158 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
2159 adfac1=adfac*(rzeta(i,j-1)-rzeta(i,j ))
2160 adfac2=adfac*(h(i,j-1)-h(i,j ))
2161 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
2162 ad_h(i,j )=ad_h(i,j )+adfac1
2163 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac2
2164 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2
2165 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac
2166 ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac
2167# if defined VAR_RHO_2D && defined SOLVE3D
2168 adfac3=adfac*(rzetasa(i,j-1)+ &
2169 & rzetasa(i,j )+ &
2170 & cff2*(rhoa(i,j-1)- &
2171 & rhoa(i,j ))* &
2172 & (zwrk(i,j-1)- &
2173 & zwrk(i,j )))
2174 adfac4=adfac2*cff2*(zwrk(i,j-1)-zwrk(i,j))
2175 adfac5=adfac2*cff2*(rhoa(i,j-1)-rhoa(i,j))
2176 ad_h(i,j-1)=ad_h(i,j-1)+adfac3
2177 ad_h(i,j )=ad_h(i,j )-adfac3
2178 ad_rzetasa(i,j-1)=ad_rzetasa(i,j-1)+adfac2
2179 ad_rzetasa(i,j )=ad_rzetasa(i,j )+adfac2
2180 ad_rhoa(i,j-1)=ad_rhoa(i,j-1)+adfac4
2181 ad_rhoa(i,j )=ad_rhoa(i,j )-adfac4
2182 ad_zwrk(i,j-1)=ad_zwrk(i,j-1)+adfac5
2183 ad_zwrk(i,j )=ad_zwrk(i,j )-adfac5
2184# endif
2185 END IF
2186!
2187 IF (i.ge.istru) THEN
2188# ifdef DIAGNOSTICS_UV
2189!! DiaU2rhs(i,j,M2pgrd)=DiaU2rhs(i,j,M2pgrd)+ &
2190!! & rubar(i,j)
2191# endif
2192!^ tl_rubar(i,j)=tl_rubar(i,j)+ &
2193!^ & cff1*on_u(i,j)* &
2194!^ & ((tl_h(i-1,j)+ &
2195!^ & tl_h(i ,j))* &
2196!^ & (rzeta(i-1,j)- &
2197!^ & rzeta(i ,j))+ &
2198!^ & (h(i-1,j)+ &
2199!^ & h(i ,j))* &
2200!^ & (tl_rzeta(i-1,j)- &
2201!^ & tl_rzeta(i ,j))+ &
2202# if defined VAR_RHO_2D && defined SOLVE3D
2203!^ & (tl_h(i-1,j)- &
2204!^ & tl_h(i ,j))* &
2205!^ & (rzetaSA(i-1,j)+ &
2206!^ & rzetaSA(i ,j)+ &
2207!^ & cff2*(rhoA(i-1,j)- &
2208!^ & rhoA(i ,j))* &
2209!^ & (zwrk(i-1,j)- &
2210!^ & zwrk(i ,j)))+ &
2211!^ & (h(i-1,j)- &
2212!^ & h(i ,j))* &
2213!^ & (tl_rzetaSA(i-1,j)+ &
2214!^ & tl_rzetaSA(i ,j)+ &
2215!^ & cff2*((tl_rhoA(i-1,j)- &
2216!^ & tl_rhoA(i ,j))* &
2217!^ & (zwrk(i-1,j)- &
2218!^ & zwrk(i ,j))+ &
2219!^ & (rhoA(i-1,j)- &
2220!^ & rhoA(i ,j))* &
2221!^ & (tl_zwrk(i-1,j)- &
2222!^ & tl_zwrk(i ,j))))+ &
2223# endif
2224!^ & (tl_rzeta2(i-1,j)- &
2225!^ & tl_rzeta2(i ,j)))
2226!^
2227 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
2228 adfac1=adfac*(rzeta(i-1,j)-rzeta(i ,j))
2229 adfac2=adfac*(h(i-1,j)+h(i ,j))
2230 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
2231 ad_h(i ,j)=ad_h(i ,j)+adfac1
2232 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac2
2233 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2
2234 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac
2235 ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac
2236# if defined VAR_RHO_2D && defined SOLVE3D
2237 adfac3=adfac*(rzetasa(i-1,j)+ &
2238 & rzetasa(i ,j)+ &
2239 & cff2*(rhoa(i-1,j)- &
2240 & rhoa(i ,j))* &
2241 & (zwrk(i-1,j)- &
2242 & zwrk(i ,j)))
2243 adfac4=adfac2*cff2*(zwrk(i-1,j)-zwrk(i,j))
2244 adfac5=adfac2*cff2*(rhoa(i-1,j)-rhoa(i,j))
2245 ad_h(i-1,j)=ad_h(i-1,j)+adfac3
2246 ad_h(i ,j)=ad_h(i ,j)-adfac3
2247 ad_rzetasa(i-1,j)=ad_rzetasa(i-1,j)+adfac2
2248 ad_rzetasa(i ,j)=ad_rzetasa(i ,j)+adfac2
2249 ad_rhoa(i-1,j)=ad_rhoa(i-1,j)+adfac4
2250 ad_rhoa(i ,j)=ad_rhoa(i ,j)-adfac4
2251 ad_zwrk(i-1,j)=ad_zwrk(i-1,j)+adfac5
2252 ad_zwrk(i ,j)=ad_zwrk(i ,j)-adfac5
2253# endif
2254 END IF
2255 END DO
2256 END DO
2257!
2258! Since coupling requires that the pressure gradient term is computed
2259! using zeta(:,:,kstp) instead of 1/3 toward zeta_new(:,:) as needed
2260! by generalized RK2 scheme, apply compensation to shift pressure
2261! gradient terms from "kstp" to 1/3 toward "knew".
2262!
2263 cff1=0.5_r8*g
2264 cff2=0.333333333333_r8
2265 cff3=1.666666666666_r8
2266
2267 DO j=jstrv-1,jend
2268 DO i=istru-1,iend
2269# if defined VAR_RHO_2D && defined SOLVE3D
2270!^ tl_rzetaSA(i,j)=tl_zwrk(i,j)* &
2271!^ & (rhoS(i,j)-rhoA(i,j))+ &
2272!^ & zwrk(i,j)* &
2273!^ & (tl_rhoS(i,j)-tl_rhoA(i,j))
2274!^
2275 adfac=zwrk(i,j)*ad_rzetasa(i,j)
2276 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
2277 & (rhos(i,j)-rhoa(i,j))*ad_rzetasa(i,j)
2278 ad_rhos(i,j)=ad_rhos(i,j)+adfac
2279 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
2280 ad_rzetasa(i,j)=0.0_r8
2281!^ tl_rzeta2(i,j)=tl_rzeta(i,j)* &
2282!^ & (cff2*zeta_new(i,j)+ &
2283!^ & cff3*zeta(i,j,kstp))+ &
2284!^ & rzeta(i,j)* &
2285!^ & (cff2*tl_zeta_new(i,j)+ &
2286!^ & cff3*tl_zeta(i,j,kstp))
2287!^
2288 adfac=rzeta(i,j)*ad_rzeta2(i,j)
2289 ad_rzeta(i,j)=ad_rzeta(i,j)+ &
2290 & (cff2*zeta_new(i,j)+ &
2291 & cff3*zeta(i,j,kstp))*ad_rzeta2(i,j)
2292 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff2*adfac
2293 tl_zeta(i,j,kstp)=tl_zeta(i,j,kstp)+cff3*adfac
2294 ad_rzeta2(i,j)=0.0_r8
2295!^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ &
2296!^ & tl_rhoS(i,j)*zwrk(i,j)
2297!^
2298 ad_zwrk(i,j)=ad_zwrk(i,j)+(1.0_r8+rhos(i,j))*ad_rzeta(i,j)
2299 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_rzeta(i,j)
2300 ad_rzeta(i,j)=0.0_r8
2301# else
2302!^ tl_rzeta2(i,j)=tl_zwrk(i,j)* &
2303!^ & (cff2*zeta_new(i,j)+ &
2304!^ & cff3*zeta(i,j,kstp))+ &
2305!^ & zwrk(i,j)* &
2306!^ & (cff2*tl_zeta_new(i,j)+ &
2307!^ & cff3*tl_zeta(i,j,kstp))
2308!^
2309 adfac=zwrk(i,j)*ad_rzeta2(i,j)
2310 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
2311 & (cff2*zeta_new(i,j)+ &
2312 & cff3*zeta(i,j,kstp))*ad_rzeta2(i,j)
2313 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff2*adfac
2314 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+cff3*adfac3
2315 ad_rzeta2(i,j)=0.0_r8
2316!^ tl_rzeta(i,j)=tl_zwrk(i,j)
2317!^
2318 ad_zwrk(i,j)=ad_zwrk(i,j)+ad_rzeta(i,j)
2319 ad_rzeta(i,j)=0.0_r8
2320# endif
2321!^ tl_zwrk(i,j)=cff2*(tl_zeta_new(i,j)-tl_zeta(i,j,kstp))
2322!^
2323 adfac=cff2*ad_zwrk(i,j)
2324 ad_zeta_new(i,j)=ad_zeta_new(i,j)+adfac
2325 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)-adfac
2326 ad_zwrk(i,j)=0.0_r8
2327 END DO
2328 END DO
2329!
2330 DO j=jstrv,jend
2331 DO i=istr,iend
2332!^ tl_rvfrc_bak(i,j,nstp)=tl_cff
2333!^
2334 ad_cff=ad_cff+ad_rvfrc_bak(i,j,nstp)
2335 ad_rvfrc_bak(i,j,nstp)=0.0_r8
2336!^ tl_rvfrc(i,j)=cff1*tl_cff+ &
2337!^ & cff2*tl_rvfrc_bak(i,j,3-nstp)+ &
2338!^ & cff3*tl_rvfrc_bak(i,j,nstp )
2339!^
2340 ad_cff=ad_cff+cff1*ad_rvfrc(i,j)
2341 ad_rvfrc_bak(i,j,3-nstp)=ad_rvfrc_bak(i,j,3-nstp)+ &
2342 & cff2*ad_rvfrc(i,j)
2343 ad_rvfrc_bak(i,j,nstp )=ad_rvfrc_bak(i,j,nstp )+ &
2344 & cff3*ad_rvfrc(i,j)
2345 ad_rvfrc(i,j)=0.0_r8
2346!^ tl_cff=tl_rvfrc(i,j)-tl_rvbar(i,j)
2347!^
2348 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_cff
2349 ad_rvbar(i,j)=ad_rvbar(i,j)-ad_cff
2350 ad_cff=0.0_r8
2351 END DO
2352 END DO
2353!
2354 DO j=jstr,jend
2355 DO i=istru,iend
2356!^ tl_rufrc_bak(i,j,nstp)=tl_cff
2357!^
2358 ad_cff=ad_cff+ad_rufrc_bak(i,j,nstp)
2359 ad_rufrc_bak(i,j,nstp)=0.0_r8
2360!^ tl_rufrc(i,j)=cff1*tl_cff+ &
2361!^ & cff2*tl_rufrc_bak(i,j,3-nstp)+ &
2362!^ & cff3*tl_rufrc_bak(i,j,nstp )
2363!^
2364 ad_cff=ad_cff+cff1*ad_rufrc(i,j)
2365 ad_rufrc_bak(i,j,3-nstp)=ad_rufrc_bak(i,j,3-nstp)+ &
2366 & cff2*ad_rufrc(i,j)
2367 ad_rufrc_bak(i,j,nstp )=ad_rufrc_bak(i,j,nstp )+ &
2368 & cff3*ad_rufrc(i,j)
2369 ad_rufrc(i,j)=0.0_r8
2370!^ tl_cff=tl_rufrc(i,j)-tl_rubar(i,j)
2371!^
2372 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_cff
2373 ad_rubar(i,j)=ad_rubar(i,j)-ad_cff
2374 ad_cff=0.0_r8
2375 END DO
2376 END DO
2377 END IF
2378#endif
2379!
2380!=======================================================================
2381! Adjoint of compute right-hand-side for the 2D momentum equations.
2382!==============Q=========================================================
2383#ifdef SOLVE3D
2384!
2385! Notice that we are suppressing the computation of momentum advection,
2386! Coriolis, and lateral viscosity terms in 3D Applications because
2387! these terms are already included in the baroclinic-to-barotropic
2388! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely
2389! omitting them, but it is a choice between recomputing them at every
2390! barotropic step or keeping them "frozen" during the fast-time
2391! stepping.
2392# ifdef STEP2D_CORIOLIS
2393! However, in some coarse grid applications with larger baroclinic
2394! timestep (say, DT around 20 minutes or larger), adding the Coriolis
2395! term in the barotropic equations is useful since f*DT is no longer
2396! small.
2397# endif
2398#endif
2399
2400#ifndef SOLVE3D
2401!
2402!-----------------------------------------------------------------------
2403! Add in bottom stress.
2404!-----------------------------------------------------------------------
2405!
2406 DO j=jstrv,jend
2407 DO i=istr,iend
2408# ifdef DIAGNOSTICS_UV
2409!! DiaV2rhs(i,j,M2bstr)=-fac
2410# endif
2411!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
2412!^
2413 ad_fac=ad_fac-ad_rvbar(i,j)
2414!^ tl_fac=tl_bvstr(i,j)*om_v(i,j)*on_v(i,j)
2415!^
2416 ad_bvstr(i,j)=ad_bvstr(i,j)+ &
2417 & om_v(i,j)*on_v(i,j)*ad_fac
2418 ad_fac=0.0_r8
2419 END DO
2420 END DO
2421
2422 DO j=jstr,jend
2423 DO i=istru,iend
2424# ifdef DIAGNOSTICS_UV
2425!! DiaU2rhs(i,j,M2bstr)=-fac
2426# endif
2427!^ tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
2428!^
2429 ad_fac=ad_fac-tl_rubar(i,j)
2430!^ tl_fac=tl_bustr(i,j)*om_u(i,j)*on_u(i,j)
2431!^
2432 ad_bustr(i,j)=ad_bustr(i,j)+ &
2433 & om_u(i,j)*on_u(i,j)*ad_fac
2434 END DO
2435 END DO
2436#else
2437# ifdef DIAGNOSTICS_UV
2438!!
2439!! Initialize the stress term if no bottom friction is defined.
2440!!
2441!! DO j=Jstr,Jend
2442!! DO i=IstrU,Iend
2443!! DiaU2rhs(i,j,M2bstr)=0.0_r8
2444!! END DO
2445!! END DO
2446!! DO j=JstrV,Jend
2447!! DO i=Istr,Iend
2448!! DiaV2rhs(i,j,M2bstr)=0.0_r8
2449!! END DO
2450!! END DO
2451# endif
2452#endif
2453
2454#if defined UV_VIS2 && !defined SOLVE3D
2455!
2456!-----------------------------------------------------------------------
2457! Adjoint of add in horizontal harmonic viscosity.
2458!-----------------------------------------------------------------------
2459!
2460! Compute BASIC STATE total depth at PSI-points.
2461!
2462 DO j=jstr,jend+1
2463 DO i=istr,iend+1
2464 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2465 & drhs(i,j-1)+drhs(i-1,j-1))
2466 END DO
2467 END DO
2468!
2469! Add in harmonic viscosity.
2470!
2471 DO j=jstr,jend
2472 DO i=istr,iend
2473 IF (j.ge.jstrv) THEN
2474# if defined DIAGNOSTICS_UV
2475!! DiaV2rhs(i,j,M2hvis)=fac
2476!! DiaV2rhs(i,j,M2xvis)= cff1
2477!! DiaV2rhs(i,j,M2yvis)=-cff2
2478# endif
2479!^ tl_rvbar(i,j)=tl_rvbar(i,j)+tl_fac
2480!^
2481 ad_fac=ad_fac+ad_rvbar(i,j)
2482!^ ad_fac=ad_cff1-ad_cff2
2483!^
2484 ad_cff1=ad_cff1+ad_fac
2485 ad_cff2=ad_cff2-ad_fac
2486 ad_fac=0.0_r8
2487!^ tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2488!^ & (tl_VFe(i ,j)-tl_VFe(i,j-1))
2489!^
2490 adfac=0.5_r8*(pm(i,j-1)+pm(i,j))*ad_cff2
2491 ad_vfe(i,j-1)=ad_vfe(i,j-1)-adfac
2492 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2493 ad_cff2=0.0_r8
2494!^ tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2495!^ & (tl_VFx(i+1,j)-tl_VFx(i,j ))
2496!^
2497 adfac=0.5_r8*(pn(i,j-1)+pn(i,j))*ad_cff1
2498 ad_vfx(i ,j)=ad_vfx(i ,j)-adfac
2499 ad_vfx(i+1,j)=ad_vfx(i+1,j)+adfac
2500 ad_cff1=0.0_r8
2501 END IF
2502!
2503 IF (i.ge.istru) THEN
2504# if defined DIAGNOSTICS_UV
2505!! DiaU2rhs(i,j,M2hvis)=fac
2506!! DiaU2rhs(i,j,M2xvis)=cff1
2507!! DiaU2rhs(i,j,M2yvis)=cff2
2508# endif
2509!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac
2510!^
2511 ad_fac=ad_fac+ad_rubar(i,j)
2512!^ tl_fac=tl_cff1+tl_cff2
2513!^
2514 ad_cff1=ad_cff1+ad_fac
2515 ad_cff2=ad_cff2+ad_fac
2516 ad_fac=0.0_r8
2517!^ tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2518!^ & (tl_UFe(i,j+1)-tl_UFe(i ,j))
2519!^
2520 adfac=0.5_r8*(pm(i-1,j)+pm(i,j))*ad_cff2
2521 ad_ufe(i,j )=ad_ufe(i,j )-adfac
2522 ad_ufe(i,j+1)=ad_ufe(i,j+1)+adfac
2523 ad_cff2=0.0_r8
2524!^ tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2525!^ & (tl_UFx(i,j )-tl_UFx(i-1,j))
2526!^
2527 adfac=0.5_r8*(pn(i-1,j)+pn(i,j))*ad_cff1
2528 ad_ufx(i-1,j)=ad_ufx(i-1,j)-adfac
2529 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2530 ad_cff1=0.0_r8
2531 END IF
2532 END DO
2533 END DO
2534!
2535! Compute flux-components of the horizontal divergence of the stress
2536! tensor (m5/s2) in XI- and ETA-directions.
2537!
2538 DO j=jstr,jend+1
2539 DO i=istr,iend+1
2540!^ tl_VFx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2541!^ tl_UFe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2542!^
2543 ad_cff=ad_cff+ &
2544 & on_p(i,j)*on_p(i,j)*ad_vfx(i,j)+ &
2545 & om_p(i,j)*om_p(i,j)*ad_ufe(i,j)
2546 ad_vfx(i,j)=0.0_r8
2547 ad_ufe(i,j)=0.0_r8
2548# ifdef WET_DRY_NOT_YET
2549!^ tl_cff=tl_cff*pmask_wet(i,j)
2550!^
2551 ad_cff=ad_cff*pmask_wet(i,j)
2552# endif
2553# ifdef MASKING
2554!^ tl_cff=tl_cff*pmask(i,j
2555!^
2556 ad_cff=ad_cff*pmask(i,j)
2557# endif
2558!^ tl_cff=visc2_p(i,j)*0.5_r8* &
2559!^ & (tl_Drhs_p(i,j)* &
2560!^ & (pmon_p(i,j)* &
2561!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2562!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2563!^ & pnom_p(i,j)* &
2564!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2565!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))+ &
2566!^ & Drhs_p(i,j)* &
2567!^ & (pmon_p(i,j)* &
2568!^ & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2569!^ & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2570!^ & pnom_p(i,j)* &
2571!^ & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2572!^ & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs))))
2573!^
2574 adfac=visc2_p(i,j)*0.5_r8*ad_cff
2575 adfac1=adfac*drhs_p(i,j)
2576 adfac2=adfac1*pmon_p(i,j)
2577 adfac3=adfac1*pnom_p(i,j)
2578 ad_drhs_p(i,j)=ad_drhs_p(i,j)+ &
2579 & (pmon_p(i,j)* &
2580 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,kstp)- &
2581 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,kstp))+ &
2582 & pnom_p(i,j)* &
2583 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,kstp)- &
2584 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,kstp)))* &
2585 & adfac
2586 ad_vbar(i-1,j,kstp)=ad_vbar(i-1,j,kstp)- &
2587 & (pn(i-1,j-1)+pn(i-1,j))*adfac2
2588 ad_vbar(i ,j,kstp)=ad_vbar(i ,j,kstp)+ &
2589 & (pn(i ,j-1)+pn(i ,j))*adfac2
2590 ad_ubar(i,j-1,kstp)=ad_ubar(i,j-1,kstp)- &
2591 & (pm(i-1,j-1)+pm(i,j-1))*adfac3
2592 ad_ubar(i,j ,kstp)=ad_ubar(i,j ,kstp)+ &
2593 & (pm(i-1,j )+pm(i,j ))*adfac3
2594 ad_cff=0.0_r8
2595 END DO
2596 END DO
2597!
2598 DO j=jstrv-1,jend
2599 DO i=istru-1,iend
2600!^ tl_VFe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2601!^ tl_UFx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2602!^
2603 ad_cff=ad_cff+ &
2604 & om_r(i,j)*om_r(i,j)*ad_vfe(i,j)+ &
2605 & on_r(i,j)*on_r(i,j)*ad_ufx(i,j)
2606 ad_vfe(i,j)=0.0_r8
2607 ad_ufx(i,j)=0.0_r8
2608!^ tl_cff=visc2_r(i,j)*0.5_r8* &
2609!^ & (tl_Drhs(i,j)* &
2610!^ & (pmon_r(i,j)* &
2611!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2612!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2613!^ & pnom_r(i,j)* &
2614!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2615!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))+ &
2616!^ & Drhs(i,j)* &
2617!^ & (pmon_r(i,j)* &
2618!^ & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2619!^ & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2620!^ & pnom_r(i,j)* &
2621!^ & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2622!^ & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs))))
2623!^
2624 adfac=visc2_r(i,j)*0.5_r8*ad_cff
2625 adfac1=adfac*drhs(i,j)
2626 adfac2=adfac1*pmon_r(i,j)
2627 adfac3=adfac1*pnom_r(i,j)
2628 ad_drhs(i,j)=ad_drhs(i,j)+ &
2629 & (pmon_r(i,j)* &
2630 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,kstp)- &
2631 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,kstp))- &
2632 & pnom_r(i,j)* &
2633 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,kstp)- &
2634 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,kstp)))* &
2635 & adfac
2636 ad_ubar(i ,j,kstp)=ad_ubar(i ,j,kstp)- &
2637 & (pn(i-1,j)+pn(i ,j))*adfac2
2638 ad_ubar(i+1,j,kstp)=ad_ubar(i+1,j,kstp)+ &
2639 & (pn(i ,j)+pn(i+1,j))*adfac2
2640 ad_vbar(i,j ,kstp)=ad_vbar(i,j ,kstp)+ &
2641 & (pm(i,j-1)+pm(i,j ))*adfac3
2642 ad_vbar(i,j+1,kstp)=ad_vbar(i,j+1,kstp)- &
2643 & (pm(i,j )+pm(i,j+1))*adfac3
2644 ad_cff=0.0_r8
2645 END DO
2646 END DO
2647!
2648! Compute total depth at PSI-points.
2649!
2650 DO j=jstr,jend+1
2651 DO i=istr,iend+1
2652!^ tl_Drhs_p(i,j)=0.25_r8*(tl_Drhs(i,j )+tl_Drhs(i-1,j )+ &
2653!^ & tl_Drhs(i,j-1)+tl_Drhs(i-1,j-1))
2654!^
2655 adfac=0.25_r8*ad_drhs_p(i,j)
2656 ad_drhs(i-1,j-1)=ad_drhs(i-1,j-1)+adfac
2657 ad_drhs(i-1,j )=ad_drhs(i-1,j )+adfac
2658 ad_drhs(i, j-1)=ad_drhs(i ,j-1)+adfac
2659 ad_drhs(i ,j )=ad_drhs(i ,j )+adfac
2660 ad_drhs_p(i,j)=0.0_r8
2661 END DO
2662 END DO
2663#endif
2664
2665#if (defined CURVGRID && defined UV_ADV) && !defined SOLVE3D
2666!
2667!-----------------------------------------------------------------------
2668! Add in curvilinear transformation terms.
2669!-----------------------------------------------------------------------
2670!
2671 DO j=jstr,jend
2672 DO i=istr,iend
2673 IF (j.ge.jstrv) THEN
2674# if defined DIAGNOSTICS_UV
2675!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
2676!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
2677!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
2678!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
2679# endif
2680!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac1
2681!^
2682 ad_fac1=ad_fac1-ad_rvbar(i,j)
2683!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
2684!^
2685 adfac=0.5_r8*ad_fac1
2686 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
2687 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2688 ad_fac1=0.0_r8
2689 END IF
2690!
2691 IF (i.ge.istru) THEN
2692# if defined DIAGNOSTICS_UV
2693!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
2694!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
2695!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
2696!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
2697# endif
2698!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2699!^
2700 ad_fac1=ad_fac1+ad_rubar(i,j)
2701!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
2702!^
2703 adfac=0.5_r8*ad_fac1
2704 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
2705 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2706 ad_fac1=0.0_r8
2707 END IF
2708 END DO
2709 END DO
2710!
2711 DO j=jstrv-1,jend
2712 DO i=istru-1,iend
2713 cff1=0.5_r8*(vbar(i,j ,krhs)+ &
2714# ifdef WEC_MELLOR
2715 & vbar_stokes(i,j )+ &
2716 & vbar_stokes(i,j+1)+ &
2717# endif
2718 & vbar(i,j+1,krhs))
2719 cff2=0.5_r8*(ubar(i ,j,krhs)+ &
2720# ifdef WEC_MELLOR
2721 & ubar_stokes(i ,j)+ &
2722 & ubar_stokes(i+1,j)+ &
2723# endif
2724 & ubar(i+1,j,krhs))
2725 cff3=cff1*dndx(i,j)
2726 cff4=cff2*dmde(i,j)
2727 cff=drhs(i,j)*(cff3-cff4)
2728# if defined DIAGNOSTICS_UV
2729!! cff=Drhs(i,j)*cff4
2730!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
2731!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
2732# endif
2733!^ tl_VFe(i,j)=tl_cff*cff2+cff*tl_cff2
2734!^ tl_UFx(i,j)=tl_cff*cff1+cff*tl_cff1
2735!^
2736 ad_cff=ad_cff+ &
2737 & cff1*ad_ufx(i,j)+ &
2738 & cff2*ad_vfe(i,j)
2739 ad_cff1=ad_cff1+cff*ad_ufx(i,j)
2740 ad_cff2=ad_cff2+cff*ad_vfe(i,j)
2741 ad_ufx(i,j)=0.0_r8
2742 ad_vfe(i,j)=0.0_r8
2743!^ tl_cff=tl_Drhs(i,j)*(cff3-cff4)+ &
2744!^ & Drhs(i,j)*(tl_cff3-tl_cff4)
2745!^
2746 adfac=drhs(i,j)*ad_cff
2747 ad_cff4=ad_cff4-adfac
2748 ad_cff3=ad_cff3+adfac
2749 ad_drhs(i,j)=ad_drhs(i,j)+(cff3-cff4)*ad_cff
2750 ad_cff=0.0_r8
2751!^ tl_cff4=tl_cff2*dmde(i,j)
2752!^
2753 ad_cff2=ad_cff2+dmde(i,j)*ad_cff4
2754 ad_cff4=0.0_r8
2755!^ tl_cff3=tl_cff1*dndx(i,j)
2756!^
2757 ad_cff1=ad_cff1+dndx(i,j)*ad_cff3
2758 ad_cff3=0.0_r8
2759!^ tl_cff2=0.5_r8*(tl_ubar(i ,j,krhs)+ &
2760# ifdef WEC_MELLOR
2761!^ & tl_ubar_stokes(i ,j)+ &
2762!^ & tl_ubar_stokes(i+1,j)+ &
2763# endif
2764!^ & tl_ubar(i+1,j,krhs))
2765!^
2766 adfac=0.5_r8*ad_cff2
2767 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac
2768 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac
2769# ifdef WEC_MELLOR
2770 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
2771 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
2772# endif
2773 ad_cff2=0.0_r8
2774!^ tl_cff1=0.5_r8*(tl_vbar(i,j ,krhs)+ &
2775# ifdef WEC_MELLOR
2776!^ & tl_vbar_stokes(i,j )+ &
2777!^ & tl_vbar_stokes(i,j+1)+ &
2778# endif
2779!^ & tl_vbar(i,j+1,krhs))
2780!^
2781 adfac=0.5_r8*ad_cff1
2782 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac
2783 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac
2784# ifdef WEC_MELLOR
2785 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
2786 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
2787# endif
2788 ad_cff1=0.0_r8
2789 END DO
2790 END DO
2791#endif
2792
2793#if (defined UV_COR & !defined SOLVE3D) || defined STEP2D_CORIOLIS
2794!
2795!-----------------------------------------------------------------------
2796! Add in Coriolis term.
2797!-----------------------------------------------------------------------
2798!
2799 DO j=jstr,jend
2800 DO i=istr,iend
2801 IF (j.ge.jstrv) THEN
2802# if defined DIAGNOSTICS_UV
2803!! DiaV2rhs(i,j,M2fcor)=-fac2
2804# endif
2805!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
2806!^
2807 ad_fac2=ad_fac2-ad_rvbar(i,j)
2808!^ tl_fac2=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
2809!^
2810 adfac=0.5_r8*ad_fac2
2811 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
2812 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2813 ad_fac2=0.0_r8
2814 END IF
2815!
2816 IF (i.ge.istru) THEN
2817# if defined DIAGNOSTICS_UV
2818!! DiaU2rhs(i,j,M2fcor)=fac1
2819# endif
2820!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2821!^
2822 ad_fac1=tl_fac1+ad_rubar(i,j)
2823!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
2824!^
2825 adfac=0.5_r8*ad_fac1
2826 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
2827 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2828 ad_fac1=0.0_r8
2829 END IF
2830 END DO
2831 END DO
2832!
2833 DO j=jstrv-1,jend
2834 DO i=istru-1,iend
2835 cff=0.5_r8*drhs(i,j)*fomn(i,j)
2836!^ tl_VFe(i,j)=tl_cff*(ubar(i ,j,krhs)+ &
2837# ifdef WEC_MELLOR
2838!^ & ubar_stokes(i ,j)+ &
2839!^ & ubar_stokes(i+1,j)+ &
2840# endif
2841!^ & ubar(i+1,j,krhs))+ &
2842!^ & cff*(tl_ubar(i ,j,krhs)+ &
2843# ifdef WEC_MELLOR
2844!^ & tl_ubar_stokes(i ,j)+ &
2845!^ & tl_ubar_stokes(i+1,j)+ &
2846# endif
2847!^ & tl_ubar(i+1,j,krhs))
2848!^
2849 adfac=cff*ad_vfe(i,j)
2850 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac
2851 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac
2852# ifdef WEC_MELLOR
2853 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
2854 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
2855# endif
2856 ad_cff=ad_cff+ &
2857 & (ubar(i ,j,krhs)+ &
2858# ifdef WEC_MELLOR
2859 & ubar_stokes(i ,j)+ &
2860 & ubar_stokes(i+1,j)+ &
2861# endif
2862 & ubar(i+1,j,krhs))*ad_vfe(i,j)
2863 ad_vfe(i,j)=0.0_r8
2864!
2865!^ tl_UFx(i,j)=tl_cff*(vbar(i,j ,krhs)+ &
2866# ifdef WEC_MELLOR
2867!^ & vbar_stokes(i,j )+ &
2868!^ & vbar_stokes(i,j+1)+ &
2869# endif
2870!^ & vbar(i,j+1,krhs))+ &
2871!^ & cff*(tl_vbar(i,j ,krhs)+ &
2872# ifdef WEC_MELLOR
2873!^ & tl_vbar_stokes(i,j )+ &
2874!^ & tl_vbar_stokes(i,j+1)+ &
2875# endif
2876!^ & tl_vbar(i,j+1,krhs))
2877!^
2878 adfac=cff*ad_ufx(i,j)
2879 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac
2880 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac
2881# ifdef WEC_MELLOR
2882 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
2883 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
2884# endif
2885 ad_cff=ad_cff+ &
2886 & (vbar(i,j ,krhs)+ &
2887# ifdef WEC_MELLOR
2888 & vbar_stokes(i,j )+ &
2889 & vbar_stokes(i,j+1)+ &
2890# endif
2891 & vbar(i,j+1,krhs))*ad_ufx(i,j)
2892 ad_ufx(i,j)=0.0_r8
2893!^ tl_cff=0.5_r8*tl_Drhs(i,j)*fomn(i,j)
2894!^
2895 ad_drhs(i,j)=ad_drhs(i,j)+0.5_r8*fomn(i,j)*ad_cff
2896 ad_cff=0.0_r8q
2897 END DO
2898 END DO
2899#endif
2900
2901#if defined UV_ADV && !defined SOLVE3D
2902!
2903!-----------------------------------------------------------------------
2904! Adjoint of add in horizontal advection of momentum.
2905!-----------------------------------------------------------------------
2906!
2907! Add advection to RHS terms.
2908!
2909 DO j=jstr,jend
2910 DO i=istr,iend
2911 IF (j.ge.jstrv) THEN
2912# if defined DIAGNOSTICS_UV
2913!! DiaV2rhs(i,j,M2xadv)=-cff1
2914!! DiaV2rhs(i,j,M2yadv)=-cff2
2915!! DiaV2rhs(i,j,M2hadv)=-fac
2916# endif
2917!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
2918!^
2919 ad_fac=ad_fac-ad_rvbar(i,j)
2920!^ tl_fac=tl_cff1+tl_cff2
2921!^
2922 ad_cff1=ad_cff1+ad_fac
2923 ad_cff2=ad_cff2+ad_fac
2924 ad_fac=0.0_r8
2925!^ tl_cff2=tl_VFe(i,j)-tl_VFe(i,j-1)
2926!^
2927 ad_vfe(i,j-1)=ad_vfe(i,j-1)-ad_cff2
2928 ad_vfe(i,j )=ad_vfe(i,j )+ad_cff2
2929 ad_cff2=0.0_r8
2930!^ tl_cff1=tl_VFx(i+1,j)-tl_VFx(i,j)
2931!^
2932 ad_vfx(i ,j)=ad_vfx(i ,j)-ad_cff1
2933 ad_vfx(i+1,j)=ad_vfx(i+1,j)+ad_cff1
2934 ad_cff1=0.0_r8
2935 END IF
2936!
2937 IF (i.ge.istru) THEN
2938# if defined DIAGNOSTICS_UV
2939!! DiaU2rhs(i,j,M2xadv)=-cff1
2940!! DiaU2rhs(i,j,M2yadv)=-cff2
2941!! DiaU2rhs(i,j,M2hadv)=-fac
2942# endif
2943!^ tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
2944!^
2945 ad_fac=ad_fac-ad_rubar(i,j)
2946!^ tl_fac=tl_cff1+tl_cff2
2947!^
2948 ad_cff1=ad_cff1+ad_fac
2949 ad_cff2=ad_cff2+ad_fac
2950 ad_fac=0.0_r8
2951!^ tl_cff2=tl_UFe(i,j+1)-tl_UFe(i,j)
2952!^
2953 ad_ufe(i,j )=ad_ufe(i,j )-ad_cff2
2954 ad_ufe(i,j+1)=ad_ufe(i,j+1)+ad_cff2
2955 ad_cff2=0.0_r8
2956!^ tl_cff1=tl_UFx(i,j)-tl_UFx(i-1,j)
2957!^
2958 ad_ufx(i-1,j)=ad_ufx(i-1,j)-ad_cff1
2959 ad_ufx(i ,j)=ad_ufx(i ,j)+ad_cff1
2960 ad_cff1=0.0_r8
2961 END IF
2962 END DO
2963 END DO
2964
2965# ifdef UV_C2ADVECTION
2966!
2967! Second-order, centered differences advection fluxes.
2968!
2969 DO j=jstrv-1,jend
2970 DO i=istr,iend
2971!^ tl_VFe(i,j)=0.25_r8* &
2972!^ & ((tl_DVom(i,j)+tl_DVom(i,j+1))* &
2973!^ & (vbar(i,j ,krhs)+ &
2974# ifdef WEC_MELLOR
2975!^ & vbar_stokes(i,j )+ &
2976!^ & vbar_stokes(i,j+1)+ &
2977# endif
2978!^ & vbar(i,j+1,krhs))+ &
2979!^ & (DVom(i,j)+DVom(i,j+1))* &
2980!^ & (tl_vbar(i,j ,krhs)+ &
2981# ifdef WEC_MELLOR
2982!^ & tl_vbar_stokes(i,j )+ &
2983!^ & tl_vbar_stokes(i,j+1)+ &
2984# endif
2985!^ & tl_vbar(i,j+1,krhs)))
2986!^
2987 adfac=0.25_r8*ad_vfe(i,j)
2988 adfac1=adfac*(vbar(i,j ,krhs)+ &
2989# ifdef WEC_MELLOR
2990 & vbar_stokes(i,j )+ &
2991 & vbar_stokes(i,j+1)+ &
2992# endif
2993 & vbar(i,j+1,krhs))
2994 adfac2=adfac*(dvom(i,j)+dvom(i,j+1))
2995 ad_dvom(i,j )=ad_dvom(i,j )+adfac1
2996 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac1
2997 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac2
2998 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac2
2999# ifdef WEC_MELLOR
3000 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac2
3001 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac2
3002# endif
3003 ad_vfe(i,j)=0.0_r8
3004 END DO
3005 END DO
3006!
3007 DO j=jstrv,jend
3008 DO i=istr,iend+1
3009!^ tl_VFx(i,j)=0.25_r8* &
3010!^ & ((tl_DUon(i,j)+tl_DUon(i,j-1))* &
3011!^ & (vbar(i ,j,krhs)+ &
3012# ifdef WEC_MELLOR
3013!^ & vbar_stokes(i ,j)+ &
3014!^ & vbar_stokes(i-1,j)+ &
3015# endif
3016!^ & vbar(i-1,j,krhs))+ &
3017!^ & (DUon(i,j)+DUon(i,j-1))* &
3018!^ & (tl_vbar(i ,j,krhs)+ &
3019# ifdef WEC_MELLOR
3020!^ & tl_vbar_stokes(i ,j)+ &
3021!^ & tl_vbar_stokes(i-1,j)+ &
3022# endif
3023!^ & tl_vbar(i-1,j,krhs)))
3024!^
3025 adfac=0.25_r8*ad_vfx(i,j)
3026 adfac1=adfac*(vbar(i ,j,krhs)+ &
3027# ifdef WEC_MELLOR
3028 & vbar_stokes(i ,j)+ &
3029 & vbar_stokes(i-1,j)+ &
3030# endif
3031 & vbar(i-1,j,krhs))
3032 adfac2=adfac*(duon(i,j)+duon(i,j-1))
3033 ad_duon(i,j )=ad_duon(i,j )+adfac1
3034 ad_duon(i,j-1)=ad_duon(i,j-1)+adfac1
3035 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+adfac2
3036 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+adfac2
3037# ifdef WEC_MELLOR
3038 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac2
3039 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac2
3040# endif
3041 ad_vfx(i,j)=0.0_r8
3042 END DO
3043 END DO
3044!
3045 DO j=jstr,jend+1
3046 DO i=istru,iend
3047!^ tl_UFe(i,j)=0.25_r8* &
3048!^ & ((tl_DVom(i,j)+tl_DVom(i-1,j))* &
3049!^ & (ubar(i,j ,krhs)+ &
3050# ifdef WEC_MELLOR
3051!^ & ubar_stokes(i,j )+ &
3052!^ & ubar_stokes(i,j-1)+ &
3053# endif
3054!^ & ubar(i,j-1,krhs))+ &
3055!^ & (DVom(i,j)+DVom(i-1,j))* &
3056!^ & (tl_ubar(i,j ,krhs)+ &
3057# ifdef WEC_MELLOR
3058!^ & tl_ubar_stokes(i,j )+ &
3059!^ & tl_ubar_stokes(i,j-1)+ &
3060# endif
3061!^ & tl_ubar(i,j-1,krhs)))
3062!^
3063 adfac=0.25_r8*ad_ufe(i,j)
3064 adfac1=adfac*(ubar(i,j ,krhs)+ &
3065# ifdef WEC_MELLOR
3066 & ubar_stokes(i,j )+ &
3067 & ubar_stokes(i,j-1)+ &
3068# endif
3069 & ubar(i,j-1,krhs))
3070 adfac2=adfac*(dvom(i,j)+dvom(i-1,j))
3071 ad_dvom(i ,j)=ad_dvom(i ,j)+adfac1
3072 ad_dvom(i-1,j)=ad_dvom(i-1,j)+adfac1
3073 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+adfac2
3074 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+adfac2
3075# ifdef WEC_MELLOR
3076 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+adfac2
3077 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac2
3078# endif
3079 ad_ufe(i,j)=0.0_r8
3080 END DO
3081 END DO
3082!
3083 DO j=jstr,jend
3084 DO i=istru-1,iend
3085!^ tl_UFx(i,j)=0.25_r8* &
3086!^ & ((tl_DUon(i,j)+tl_DUon(i+1,j))* &
3087!^ & (ubar(i ,j,krhs)+ &
3088# ifdef WEC_MELLOR
3089!^ & ubar_stokes(i ,j)+ &
3090!^ & ubar_stokes(i+1,j)+ &
3091# endif
3092!^ & ubar(i+1,j,krhs))+ &
3093!^ & (DUon(i,j)+DUon(i+1,j))* &
3094!^ & (tl_ubar(i ,j,krhs)+ &
3095# ifdef WEC_MELLOR
3096!^ & tl_ubar_stokes(i ,j)+ &
3097!^ & tl_ubar_stokes(i+1,j)+ &
3098# endif
3099!^ & tl_ubar(i+1,j,krhs)))
3100!^
3101 adfac=0.25_r8*ad_ufx(i,j)
3102 adfac1=adfac*(ubar(i ,j,krhs)+ &
3103# ifdef WEC_MELLOR
3104 & ubar_stokes(i ,j)+ &
3105 & ubar_stokes(i+1,j)+ &
3106# endif
3107 & ubar(i+1,j,krhs))
3108 adfac2=adfac*(duon(i,j)+duon(i+1,j))
3109 ad_duon(i ,j)=ad_duon(i ,j)+adfac1
3110 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac1
3111 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac2
3112 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac2
3113# ifdef WEC_MELLOR
3114 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac2
3115 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac2
3116# endif
3117 ad_ufx(i,j)=0.0_r8
3118 END DO
3119 END DO
3120
3121# elif defined UV_C4ADVECTION
3122!
3123! Fourth-order, centered differences v-momentum advection fluxes.
3124!
3125 DO j=jstrvm1,jendp1 ! BASIC STATE
3126 DO i=istr,iend
3127 grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ &
3128# ifdef WEC_MELLOR
3129 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
3130 & vbar_stokes(i,j+1)+ &
3131# endif
3132 & vbar(i,j+1,krhs)
3133 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
3134 END DO
3135 END DO
3136 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3137 IF (domain(ng)%Northern_Edge(tile)) THEN
3138 DO i=istr,iend
3139 grad(i,jend+1)=grad(i,jend)
3140 dgrad(i,jend+1)=dgrad(i,jend)
3141 END DO
3142 END IF
3143 END IF
3144 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3145 IF (domain(ng)%Southern_Edge(tile)) THEN
3146 DO i=istr,iend
3147 grad(i,jstr)=grad(i,jstr+1)
3148 dgrad(i,jstr)=dgrad(i,jstr+1)
3149 END DO
3150 END IF
3151 END IF
3152! d/dy(Dvv/m)
3153 cff=1.0_r8/6.0_r8
3154 DO j=jstrv-1,jend
3155 DO i=istr,iend
3156!^ tl_VFe(i,j)=0.25_r8* &
3157!^ & ((tl_vbar(i,j ,krhs)+ &
3158# ifdef WEC_MELLOR
3159!^ & tl_vbar_stokes(i,j )+ &
3160!^ & tl_vbar_stokes(i,j+1)+ &
3161# endif
3162!^ & tl_vbar(i,j+1,krhs)- &
3163!^ & cff*(tl_grad (i,j)+tl_grad (i,j+1)))* &
3164!^ & (DVom(i,j)+DVom(i,j+1)- &
3165!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))+ &
3166!^ & (vbar(i,j ,krhs)+ &
3167# ifdef WEC_MELLOR
3168!^ & vbar_stokes(i,j )+ &
3169!^ & vbar_stokes(i,j+1)+ &
3170# endif
3171!^ & vbar(i,j+1,krhs)- &
3172!^ & cff*(grad (i,j)+grad (i,j+1)))* &
3173!^ & (tl_DVom(i,j)+tl_DVom(i,j+1)- &
3174!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j+1))))
3175!^
3176 adfac=0.25_r8*ad_vfe(i,j)
3177 adfac1=adfac*(dvom(i,j)+dvom(i,j+1)- &
3178 & cff*(dgrad(i,j)+dgrad(i,j+1)))
3179 adfac2=adfac1*cff
3180 adfac3=adfac*(vbar(i,j ,krhs)+ &
3181# ifdef WEC_MELLOR
3182 & vbar_stokes(i,j )+ &
3183 & vbar_stokes(i,j+1)+ &
3184# endif
3185 & vbar(i,j+1,krhs)- &
3186 & cff*(grad(i,j)+grad(i,j+1)))
3187 adfac4=adfac3*cff
3188 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)+adfac1
3189 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+adfac1
3190# ifdef WEC_MELLOR
3191 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac1
3192 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac1
3193# endif
3194 ad_grad(i,j )=ad_grad(i,j )-adfac2
3195 ad_grad(i,j+1)=ad_grad(i,j+1)-adfac2
3196 ad_dvom(i,j )=ad_dvom(i,j )+adfac3
3197 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac3
3198 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3199 ad_dgrad(i,j+1)=ad_dgrad(i,j+1)-adfac4
3200 ad_vfe(i,j)=0.0_r8
3201 END DO
3202 END DO
3203!
3204 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3205 IF (domain(ng)%Northern_Edge(tile)) THEN
3206 DO i=istr,iend
3207!^ tl_Dgrad(i,Jend+1)=tl_Dgrad(i,Jend)
3208!^
3209 ad_dgrad(i,jend)=ad_dgrad(i,jend)+ad_dgrad(i,jend+1)
3210 ad_dgrad(i,jend+1)=0.0_r8
3211!^ tl_grad (i,Jend+1)=tl_grad (i,Jend)
3212!^
3213 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3214 ad_grad(i,jend+1)=0.0_r8
3215 END DO
3216 END IF
3217 END IF
3218 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3219 IF (domain(ng)%Southern_Edge(tile)) THEN
3220 DO i=istr,iend
3221!^ tl_Dgrad(i,Jstr)=tl_Dgrad(i,Jstr+1)
3222!^
3223 ad_dgrad(i,jstr+1)=ad_dgrad(i,jstr+1)+ad_dgrad(i,jstr)
3224 ad_dgrad(i,jstr)=0.0_r8
3225!^ tl_grad (i,Jstr)=tl_grad (i,Jstr+1)
3226!^
3227 ad_grad(i,jstr+1)=ad_grad(i,jstr+1)+ad_grad(i,jstr)
3228 ad_grad(i,jstr)=0.0_r8
3229 END DO
3230 END IF
3231 END IF
3232 DO j=jstrvm1,jendp1
3233 DO i=istr,iend
3234!^ tl_Dgrad(i,j)=tl_DVom(i,j-1)-2.0_r8*tl_DVom(i,j)+ &
3235!^ & tl_DVom(i,j+1)
3236!^
3237 ad_dvom(i,j-1)=ad_dvom(i,j-1)+ad_dgrad(i,j)
3238 ad_dvom(i,j )=ad_dvom(i,j )-2.0_r8*ad_dgrad(i,j)
3239 ad_dvom(i,j+1)=ad_dvom(i,j+1)+ad_dgrad(i,j)
3240 ad_dgrad(i,j)=0.0_r8
3241!^ tl_grad(i,j)=tl_vbar(i,j-1,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
3242# ifdef WEC_MELLOR
3243!^ & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
3244!^ & tl_vbar_stokes(i,j+1)+ &
3245# endif
3246!^ & tl_vbar(i,j+1,krhs)
3247!^
3248 ad_vbar(i,j-1,krhs)=ad_vbar(i,j-1,krhs)+ad_grad(i,j)
3249 ad_vbar(i,j ,krhs)=ad_vbar(i,j ,krhs)- &
3250 & 2.0_r8*ad_grad(i,j)
3251 ad_vbar(i,j+1,krhs)=ad_vbar(i,j+1,krhs)+ad_grad(i,j)
3252# ifdef WEC_MELLOR
3253 ad_vbar_stokes(i,j-1)=ad_vbar_stokes(i,j-1)+ad_grad(i,j)
3254 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )- &
3255 & 2.0_r8*ad_grad(i,j)
3256 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+ad_grad(i,j)
3257# endif
3258 ad_grad(i,j)=0.0_r8
3259 END DO
3260 END DO
3261!
3262 DO j=jstrv,jend ! BASIC STATE
3263 DO i=istrm1,iendp1
3264 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ &
3265# ifdef WEC_MELLOR
3266 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
3267 & vbar_stokes(i+1,j)+ &
3268# endif
3269 & vbar(i+1,j,krhs)
3270 END DO
3271 END DO
3272 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3273 IF (domain(ng)%Western_Edge(tile)) THEN
3274 DO j=jstrv,jend
3275 grad(istr-1,j)=grad(istr,j)
3276 END DO
3277 END IF
3278 END IF
3279 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3280 IF (domain(ng)%Eastern_Edge(tile)) THEN
3281 DO j=jstrv,jend
3282 grad(iend+1,j)=grad(iend,j)
3283 END DO
3284 END IF
3285 END IF
3286 DO j=jstrv-1,jend
3287 DO i=istr,iend+1
3288 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
3289 END DO
3290 END DO
3291! d/dx(Duv/n)
3292 cff=1.0_r8/6.0_r8
3293 DO j=jstrv,jend
3294 DO i=istr,iend+1
3295!^ tl_VFx(i,j)=0.25_r8* &
3296!^ & ((tl_vbar(i ,j,krhs)+ &
3297# ifdef WEC_MELLOR
3298!^ & tl_vbar_stokes(i ,j)+ &
3299!^ & tl_vbar_stokes(i-1,j)+ &
3300# endif
3301!^ & tl_vbar(i-1,j,krhs)- &
3302!^ & cff*(tl_grad (i,j)+tl_grad (i-1,j)))* &
3303!^ & (DUon(i,j)+DUon(i,j-1)- &
3304!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))+ &
3305!^ & (vbar(i ,j,krhs)+ &
3306# ifdef WEC_MELLOR
3307!^ & vbar_stokes(i ,j)+ &
3308!^ & vbar_stokes(i-1,j)+ &
3309# endif
3310!^ & vbar(i-1,j,krhs)- &
3311!^ & cff*(grad (i,j)+grad (i-1,j)))* &
3312!^ & (tl_DUon(i,j)+tl_DUon(i,j-1)- &
3313!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j-1))))
3314!^
3315 adfac=0.25_r8*ad_vfx(i,j)
3316 adfac1=adfac*(duon(i,j)+duon(i,j-1)- &
3317 & cff*(dgrad(i,j)+dgrad(i,j-1)))
3318 adfac2=adfac1*cff
3319 adfac3=adfac*(vbar(i ,j,krhs)+ &
3320# ifdef WEC_MELLOR
3321 & vbar_stokes(i ,j)+ &
3322 & vbar_stokes(i-1,j)+ &
3323# endif
3324 & vbar(i-1,j,krhs)- &
3325 & cff*(grad(i,j)+grad(i-1,j)))
3326 adfac4=adfac3*cff
3327 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+adfac1
3328 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)+adfac1
3329# ifdef WEC_MELLOR
3330 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac1
3331 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac1
3332# endif
3333 ad_grad(i-1,j)=ad_grad(i-1,j)-adfac2
3334 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
3335 ad_duon(i,j-1)=ad_duon(i,j-1)+adfac3
3336 ad_duon(i,j )=ad_duon(i,j )+adfac3
3337 ad_dgrad(i,j-1)=ad_dgrad(i,j-1)-adfac4
3338 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3339 ad_vfx(i,j)=0.0_r8
3340 END DO
3341 END DO
3342!
3343 DO j=jstrv-1,jend
3344 DO i=istr,iend+1
3345!^ tl_Dgrad(i,j)=tl_DUon(i,j-1)-2.0_r8*tl_DUon(i,j)+ &
3346!^ & tl_DUon(i,j+1)
3347!^
3348 ad_duon(i,j-1)=ad_duon(i,j-1)+ad_dgrad(i,j)
3349 ad_duon(i,j )=ad_duon(i,j )-2.0_r8*ad_dgrad(i,j)
3350 ad_duon(i,j+1)=ad_duon(i,j+1)+ad_dgrad(i,j)
3351 ad_dgrad(i,j)=0.0_r8
3352 END DO
3353 END DO
3354 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3355 IF (domain(ng)%Eastern_Edge(tile)) THEN
3356 DO j=jstrv,jend
3357!^ tl_grad(Iend+1,j)=tl_grad(Iend,j)
3358!^
3359 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
3360 ad_grad(iend+1,j)=0.0_r8
3361 END DO
3362 END IF
3363 END IF
3364 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3365 IF (domain(ng)%Western_Edge(tile)) THEN
3366 DO j=jstrv,jend
3367!^ tl_grad(Istr-1,j)=tl_grad(Istr,j)
3368!^
3369 ad_grad(istr,j)=ad_grad(istr,j)+ad_grad(istr-1,j)
3370 ad_grad(istr-1,j)=0.0_r8
3371 END DO
3372 END IF
3373 END IF
3374 DO j=jstrv,jend
3375 DO i=istrm1,iendp1
3376!^ tl_grad(i,j)=tl_vbar(i-1,j,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
3377# ifdef WEC_MELLOR
3378!^ & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
3379!^ & tl_vbar_stokes(i+1,j)+ &
3380# endif
3381!^ & tl_vbar(i+1,j,krhs)
3382!^
3383 ad_vbar(i-1,j,krhs)=ad_vbar(i-1,j,krhs)+ad_grad(i,j)
3384 ad_vbar(i ,j,krhs)=ad_vbar(i ,j,krhs)- &
3385 & 2.0_r8*ad_grad(i,j)
3386 ad_vbar(i+1,j,krhs)=ad_vbar(i+1,j,krhs)+ad_grad(i,j)
3387# ifdef WEC_MELLOR
3388 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+ad_grad(i,j)
3389 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)- &
3390 & 2.0_r8*ad_grad(i,j)
3391 ad_vbar_stokes(i+1,j)=ad_vbar_stokes(i+1,j)+ad_grad(i,j)
3392# endif
3393 ad_grad(i,j)=0.0_r8
3394 END DO
3395 END DO
3396!
3397! Fourth-order, centered differences u-momentum advection fluxes.
3398!
3399 DO j=jstrm1,jendp1 ! BASIC STATE
3400 DO i=istru,iend
3401 grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ &
3402# ifdef WEC_MELLOR
3403 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
3404 & ubar_stokes(i,j+1)+ &
3405# endif
3406 & ubar(i,j+1,krhs)
3407 END DO
3408 END DO
3409 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3410 IF (domain(ng)%Southern_Edge(tile)) THEN
3411 DO i=istru,iend
3412 grad(i,jstr-1)=grad(i,jstr)
3413 END DO
3414 END IF
3415 END IF
3416 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3417 IF (domain(ng)%Northern_Edge(tile)) THEN
3418 DO i=istru,iend
3419 grad(i,jend+1)=grad(i,jend)
3420 END DO
3421 END IF
3422 END IF
3423 DO j=jstr,jend+1
3424 DO i=istru-1,iend
3425 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
3426 END DO
3427 END DO
3428! d/dy(Duv/m)
3429 cff=1.0_r8/6.0_r8
3430 DO j=jstr,jend+1
3431 DO i=istru,iend
3432!^ tl_UFe(i,j)=0.25_r8* &
3433!^ & ((tl_ubar(i,j ,krhs)+ &
3434# ifdef WEC_MELLOR
3435!^ & tl_ubar_stokes(i,j )+ &
3436!^ & tl_ubar_stokes(i,j-1)+ &
3437# endif
3438!^ & tl_ubar(i,j-1,krhs)- &
3439!^ & cff*(tl_grad (i,j)+tl_grad (i,j-1)))* &
3440!^ & (DVom(i,j)+DVom(i-1,j)- &
3441!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))+ &
3442!^ & (ubar(i,j ,krhs)+ &
3443# ifdef WEC_MELLOR
3444!^ & ubar_stokes(i,j )+ &
3445!^ & ubar_stokes(i,j-1)+ &
3446# endif
3447!^ & ubar(i,j-1,krhs)- &
3448!^ & cff*(grad (i,j)+grad (i,j-1)))* &
3449!^ & (tl_DVom(i,j)+tl_DVom(i-1,j)- &
3450!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i-1,j))))
3451!^
3452 adfac=0.25_r8*ad_ufe(i,j)
3453 adfac1=adfac*(dvom(i,j)+dvom(i-1,j)- &
3454 & cff*(dgrad(i,j)+dgrad(i-1,j)))
3455 adfac2=adfac1*cff
3456 adfac3=adfac*(ubar(i,j ,krhs)+ &
3457# ifdef WEC_MELLOR
3458 & ubar_stokes(i,j )+ &
3459 & ubar_stokes(i,j-1)+ &
3460# endif
3461 & ubar(i,j-1,krhs)- &
3462 & cff*(grad(i,j)+grad(i,j-1)))
3463 adfac4=adfac3*cff
3464 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+adfac1
3465 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)+adfac1
3466# ifdef WEC_MELLOR
3467 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+adfac1
3468 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac1
3469# endif
3470 ad_grad(i,j-1)=ad_grad(i,j-1)-adfac2
3471 ad_grad(i,j )=ad_grad(i,j )-adfac2
3472 ad_dvom(i-1,j)=ad_dvom(i-1,j)+adfac3
3473 ad_dvom(i ,j)=ad_dvom(i ,j)+adfac3
3474 ad_dgrad(i-1,j)=ad_dgrad(i-1,j)-adfac4
3475 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
3476 ad_ufe(i,j)=0.0_r8
3477 END DO
3478 END DO
3479!
3480 DO j=jstr,jend+1
3481 DO i=istru-1,iend
3482!^ tl_Dgrad(i,j)=tl_DVom(i-1,j)-2.0_r8*tl_DVom(i,j)+ &
3483!^ & tl_DVom(i+1,j)
3484!^
3485 ad_dvom(i-1,j)=ad_dvom(i-1,j)+ad_dgrad(i,j)
3486 ad_dvom(i ,j)=ad_dvom(i ,j)-2.0_r8*ad_dgrad(i,j)
3487 ad_dvom(i+1,j)=ad_dvom(i+1,j)+ad_dgrad(i,j)
3488 ad_dgrad(i,j)=0.0_r8
3489 END DO
3490 END DO
3491 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3492 IF (domain(ng)%Northern_Edge(tile)) THEN
3493 DO i=istru,iend
3494!^ tl_grad(i,Jend+1)=tl_grad(i,Jend)
3495!^
3496 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3497 ad_grad(i,jend+1)=0.0_r8
3498 END DO
3499 END IF
3500 END IF
3501 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3502 IF (domain(ng)%Southern_Edge(tile)) THEN
3503 DO i=istru,iend
3504!^ tl_grad(i,Jstr-1)=tl_grad(i,Jstr)
3505!^
3506 ad_grad(i,jstr)=ad_grad(i,jstr)+ad_grad(i,jstr-1)
3507 ad_grad(i,jstr-1)=0.0_r8
3508 END DO
3509 END IF
3510 END IF
3511 DO j=jstrm1,jendp1
3512 DO i=istru,iend
3513!^ tl_grad(i,j)=tl_ubar(i,j-1,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
3514# ifdef WEC_MELLOR
3515!^ & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
3516!^ & tl_ubar_stokes(i,j+1)+ &
3517# endif
3518!^ & tl_ubar(i,j+1,krhs)
3519!^
3520 ad_ubar(i,j-1,krhs)=ad_ubar(i,j-1,krhs)+ad_grad(i,j)
3521 ad_ubar(i,j ,krhs)=ad_ubar(i,j ,krhs)- &
3522 & 2.0_r8*ad_grad(i,j)
3523 ad_ubar(i,j+1,krhs)=ad_ubar(i,j+1,krhs)+ad_grad(i,j)
3524# ifdef WEC_MELLOR
3525 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+ad_grad(i,j)
3526 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j)- &
3527 & 2.0_r8*ad_grad(i,j)
3528 ad_ubar_stokes(i,j+1)=ad_ubar_stokes(i,j+1)+ad_grad(i,j)
3529# endif
3530 ad_grad(i,j)=0.0_r8
3531 END DO
3532 END DO
3533!
3534 DO j=jstr,jend ! BASIC STATE
3535 DO i=istrum1,iendp1
3536 grad(i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ &
3537# ifdef WEC_MELLOR
3538 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
3539 & ubar_stokes(i+1,j)+ &
3540# endif
3541 & ubar(i+1,j,krhs)
3542 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
3543 END DO
3544 END DO
3545 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3546 IF (domain(ng)%Western_Edge(tile)) THEN
3547 DO j=jstr,jend
3548 grad(istr,j)=grad(istr+1,j)
3549 dgrad(istr,j)=dgrad(istr+1,j)
3550 END DO
3551 END IF
3552 END IF
3553 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3554 IF (domain(ng)%Eastern_Edge(tile)) THEN
3555 DO j=jstr,jend
3556 grad(iend+1,j)=grad(iend,j)
3557 dgrad(iend+1,j)=dgrad(iend,j)
3558 END DO
3559 END IF
3560 END IF
3561! d/dx(Duu/n)
3562 cff=1.0_r8/6.0_r8
3563 DO j=jstr,jend
3564 DO i=istru-1,iend
3565!^ tl_UFx(i,j)=0.25_r8* &
3566!^ & ((ubar(i ,j,krhs)+ &
3567# ifdef WEC_MELLOR
3568!^ & ubar_stokes(i ,j)+ &
3569!^ & ubar_stokes(i+1,j)+ &
3570# endif
3571!^ & ubar(i+1,j,krhs)- &
3572!^ & cff*(grad (i,j)+grad (i+1,j)))* &
3573!^ & (tl_DUon(i,j)+tl_DUon(i+1,j)- &
3574!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i+1,j)))+ &
3575!^ & (tl_ubar(i ,j,krhs)+ &
3576# ifdef WEC_MELLOR
3577!^ & tl_ubar_stokes(i ,j)+ &
3578!^ & tl_ubar_stokes(i+1,j)+ &
3579# endif
3580!^ & tl_ubar(i+1,j,krhs)- &
3581!^ & cff*(tl_grad (i,j)+tl_grad (i+1,j)))* &
3582!^ & (DUon(i,j)+DUon(i+1,j)- &
3583!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j))))
3584!^
3585 adfac=0.25_r8*ad_ufx(i,j)
3586 adfac1=adfac*(duon(i,j)+duon(i+1,j)- &
3587 & cff*(dgrad(i,j)+dgrad(i+1,j)))
3588 adfac2=adfac1*cff
3589 adfac3=adfac*(ubar(i ,j,krhs)+ &
3590# ifdef WEC_MELLOR
3591 & ubar_stokes(i ,j)+ &
3592 & ubar_stokes(i+1,j)+ &
3593# endif
3594 & ubar(i+1,j,krhs)- &
3595 & cff*(grad(i,j)+grad(i+1,j)))
3596 adfac4=adfac3*cff
3597 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)+adfac1
3598 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+adfac1
3599# ifdef WEC_MELLOR
3600 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac1
3601 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac1
3602# endif
3603 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
3604 ad_grad(i+1,j)=ad_grad(i+1,j)-adfac2
3605 ad_duon(i ,j)=ad_duon(i ,j)+adfac3
3606 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac3
3607 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
3608 ad_dgrad(i+1,j)=ad_dgrad(i+1,j)-adfac4
3609 ad_ufx(i,j)=0.0_r8
3610 END DO
3611 END DO
3612!
3613 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3614 IF (domain(ng)%Eastern_Edge(tile)) THEN
3615 DO j=jstr,jend
3616!^ tl_Dgrad(Iend+1,j)=tl_Dgrad(Iend,j)
3617!^
3618 ad_dgrad(iend,j)=ad_dgrad(iend,j)+ad_dgrad(iend+1,j)
3619 ad_dgrad(iend+1,j)=0.0_r8
3620!^ tl_grad (Iend+1,j)=tl_grad (Iend,j)
3621!^
3622 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
3623 ad_grad(iend+1,j)=0.0_r8
3624 END DO
3625 END IF
3626 END IF
3627 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3628 IF (domain(ng)%Western_Edge(tile)) THEN
3629 DO j=jstr,jend
3630!^ tl_Dgrad(Istr,j)=tl_Dgrad(Istr+1,j)
3631!^
3632 ad_dgrad(istr+1,j)=ad_dgrad(istr+1,j)+ad_dgrad(istr,j)
3633 ad_dgrad(istr,j)=0.0_r8
3634!^ tl_grad (Istr,j)=tl_grad (Istr+1,j)
3635!^
3636 ad_grad(istr+1,j)=ad_grad(istr+1,j)+ad_grad(istr,j)
3637 ad_grad(istr,j)=0.0_r8
3638 END DO
3639 END IF
3640 END IF
3641 DO j=jstr,jend
3642 DO i=istrum1,iendp1
3643!^ tl_Dgrad(i,j)=tl_DUon(i-1,j)-2.0_r8*tl_DUon(i,j)+ &
3644!^ & tl_DUon(i+1,j)
3645!^
3646 ad_duon(i-1,j)=ad_duon(i-1,j)+ad_dgrad(i,j)
3647 ad_duon(i ,j)=ad_duon(i ,j)-2.0_r8*ad_dgrad(i,j)
3648 ad_duon(i+1,j)=ad_duon(i+1,j)+ad_dgrad(i,j)
3649 ad_dgrad(i,j)=0.0_r8
3650!^ tl_grad(i,j)=tl_ubar(i-1,j,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
3651# ifdef WEC_MELLOR
3652!^ & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
3653!^ & tl_ubar_stokes(i+1,j)+ &
3654# endif
3655!^ & tl_ubar(i+1,j,krhs)
3656!^
3657 ad_ubar(i-1,j,krhs)=ad_ubar(i-1,j,krhs)+ad_grad(i,j)
3658 ad_ubar(i ,j,krhs)=ad_ubar(i ,j,krhs)- &
3659 & 2.0_r8*ad_grad(i,j)
3660 ad_ubar(i+1,j,krhs)=ad_ubar(i+1,j,krhs)+ad_grad(i,j)
3661# ifdef NEARHSORE_MELLOR
3662 ad_ubar_stokes(i-1,j)=ad_ubar_stokes(i-1,j)+ad_grad(i,j)
3663 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)- &
3664 & 2.0_r8*ad_grad(i,j)
3665 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+ad_grad(i,j)
3666# endif
3667 ad_grad(i,j)=0.0_r8
3668 END DO
3669 END DO
3670# endif
3671#endif
3672!
3673!-----------------------------------------------------------------------
3674! Adjoint of compute pressure-gradient terms.
3675!-----------------------------------------------------------------------
3676!
3677! Notice that "rubar" and "rvbar" are computed within the same to allow
3678! shared references to array elements (i,j), which increases the
3679! computational density by almost a factor of 1.5 resulting in overall
3680! more efficient code.
3681!
3682 cff1=0.5*g
3683 cff2=0.333333333333_r8
3684#if !defined SOLVE3D && defined ATM_PRESS
3685 fac=0.5_r8*100.0_r8/rho0
3686#endif
3687 DO j=jstr,jend
3688 DO i=istr,iend
3689 IF (j.ge.jstrv) THEN
3690#ifdef DIAGNOSTICS_UV
3691!! DiaV2rhs(i,j,M2pgrd)=rvbar(i,j)
3692#endif
3693#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
3694!^ tl_rvbar(i,j)=tl_rvbar(i,j)- &
3695!^ & cff1*om_v(i,j)* &
3696!^ & ((tl_h(i,j-1)+tl_h(i,j)+ &
3697!^ & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
3698!^ & (eq_tide(i,j)-eq_tide(i,j-1))+ &
3699!^ & (h(i,j-1)+h(i,j)+ &
3700!^ & rzeta(i,j-1)+rzeta(i,j))* &
3701!^ & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
3702!^
3703 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
3704 adfac1=adfac*(eq_tide(i,j)-eq_tide(i,j-1))
3705 adfac2=adfac*(h(i,j-1)+h(i,j)+ &
3706 & rzeta(i,j-1)+rzeta(i,j))
3707 ad_h(i,j-1)=ad_h(i,j-1)-adfac1
3708 ad_h(i,j )=ad_h(i,j )-adfac1
3709 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)-adfac1
3710 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac1
3711 ad_eq_tide(i,j-1)=ad_eq_tide(i,j-1)+adfac2
3712 ad_eq_tide(i,j )=ad_eq_tide(i,j )-adfac2
3713#endif
3714#if defined ATM_PRESS && !defined SOLVE3D
3715!^ tl_rvbar(i,j)=tl_rvbar(i,j)- &
3716!^ & fac*om_v(i,j)* &
3717!^ & (tl_h(i,j-1)+tl_h(i,j)+ &
3718!^ & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
3719!^ & (Pair(i,j)-Pair(i,j-1))
3720!^
3721 adfac=-fac*om_v(i,j)*(pair(i,j)-pair(i,j-1)*ad_rvbar(i,j)
3722 ad_h(i,j-1)=ad_h(i,j-1)+adfac
3723 ad_h(i,j )=ad_h(i,j )+adfac
3724 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac
3725 ad_rzeta(i,j )=ad_rzeta(i,j )+adfac
3726#endif
3727!^ tl_rvbar(i,j)=cff1*om_v(i,j)* &
3728!^ & ((tl_h(i,j-1)+ &
3729!^ & tl_h(i,j ))* &
3730!^ & (rzeta(i,j-1)- &
3731!^ & rzeta(i,j ))+ &
3732!^ & (h(i,j-1)+ &
3733!^ & h(i,j ))* &
3734!^ & (tl_rzeta(i,j-1)- &
3735!^ & tl_rzeta(i,j ))+ &
3736#if defined VAR_RHO_2D && defined SOLVE3D
3737!^ & (tl_h(i,j-1)- &
3738!^ & tl_h(i,j ))* &
3739!^ & (rzetaSA(i,j-1)+ &
3740!^ & rzetaSA(i,j )+ &
3741!^ & cff2*(rhoA(i,j-1)- &
3742!^ & rhoA(i,j ))* &
3743!^ & (zwrk(i,j-1)- &
3744!^ & zwrk(i,j )))+ &
3745!^ & (h(i,j-1)- &
3746!^ & h(i,j ))* &
3747!^ & (tl_rzetaSA(i,j-1)+ &
3748!^ & tl_rzetaSA(i,j )+ &
3749!^ & cff2*((tl_rhoA(i,j-1)- &
3750!^ & tl_rhoA(i,j ))* &
3751!^ & (zwrk(i,j-1)- &
3752!^ & zwrk(i,j ))+ &
3753!^ & (rhoA(i,j-1)- &
3754!^ & rhoA(i,j ))* &
3755!^ & (tl_zwrk(i,j-1)- &
3756!^ & tl_zwrk(i,j ))))+ &
3757#endif
3758!^ & (tl_rzeta2(i,j-1)- &
3759!^ & tl_rzeta2(i,j )))
3760!^
3761 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
3762 adfac1=adfac*(rzeta(i,j-1)-rzeta(i,j ))
3763 adfac2=adfac*(h(i,j-1)+h(i,j ))
3764 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
3765 ad_h(i,j )=ad_h(i,j )+adfac1
3766 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac2
3767 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2
3768 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac
3769 ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac
3770#if defined VAR_RHO_2D && defined SOLVE3D
3771 adfac3=adfac*(rzetasa(i,j-1)+ &
3772 & rzetasa(i,j )+ &
3773 & cff2*(rhoa(i,j-1)- &
3774 & rhoa(i,j ))* &
3775 & (zwrk(i,j-1)- &
3776 & zwrk(i,j )))
3777 adfac4=adfac2*cff2*(zwrk(i,j-1)-zwrk(i,j))
3778 adfac5=adfac2*cff2*(rhoa(i,j-1)-rhoa(i,j))
3779 ad_h(i,j-1)=ad_h(i,j-1)+adfac3
3780 ad_h(i,j )=ad_h(i,j )-adfac3
3781 ad_rzetasa(i,j-1)=ad_rzetasa(i,j-1)+adfac2
3782 ad_rzetasa(i,j )=ad_rzetasa(i,j )+adfac2
3783 ad_rhoa(i,j-1)=ad_rhoa(i,j-1)+adfac4
3784 ad_rhoa(i,j )=ad_rhoa(i,j )-adfac4
3785 ad_zwrk(i,j-1)=ad_zwrk(i,j-1)+adfac5
3786 ad_zwrk(i,j )=ad_zwrk(i,j )-adfac5
3787#endif
3788 ad_rvbar(i,j)=0.0_r8
3789 END IF
3790!
3791 IF (i.ge.istru) THEN
3792#ifdef DIAGNOSTICS_UV
3793!! DiaU2rhs(i,j,M2pgrd)=rubar(i,j)
3794#endif
3795#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
3796!^ tl_rubar(i,j)=tl_rubar(i,j)- &
3797!^ & cff1*on_u(i,j)* &
3798!^ & ((tl_h(i-1,j)+tl_h(i,j)+ &
3799!^ & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
3800!^ & (eq_tide(i,j)-eq_tide(i-1,j))+ &
3801!^ & (h(i-1,j)+h(i,j)+ &
3802!^ & rzeta(i-1,j)+rzeta(i,j))* &
3803!^ & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
3804!^
3805 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
3806 adfac1=adfac*(eq_tide(i,j)-eq_tide(i-1,j))
3807 adfac2=adfac*(h(i-1,j)+h(i,j)+ &
3808 & rzeta(i-1,j)+rzeta(i,j))
3809 ad_h(i-1,j)=ad_h(i-1,j)-adfac1
3810 ad_h(i ,j)=ad_h(i ,j)-adfac1
3811 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)-adfac1
3812 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac1
3813 ad_eq_tide(i-1,j)=ad_eq_tide(i-1,j)+adfac2
3814 ad_eq_tide(i ,j)=ad_eq_tide(i ,j)-adfac2
3815#endif
3816#if defined ATM_PRESS && !defined SOLVE3D
3817!^ tl_rubar(i,j)=tl_rubar(i,j)- &
3818!^ & fac*on_u(i,j)* &
3819!^ & (tl_h(i-1,j)+tl_h(i,j)+ &
3820!^ & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
3821!^ & (Pair(i,j)-Pair(i-1,j))
3822!^
3823 adfac=-fac*on_u(i,j)*(pair(i,j)-pair(i-1,j))*ad_rubar(i,j)
3824 ad_h(i-1,j)=ad_h(i-1,j)+adfac
3825 ad_h(i ,j)=ad_h(i ,j)+adfac
3826 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac
3827 ad_rzeta(i ,j)=ad_rzeta(i ,j)+adfac
3828#endif
3829!^ tl_rubar(i,j)=cff1*on_u(i,j)* &
3830!^ & ((tl_h(i-1,j)+ &
3831!^ & tl_h(i ,j))* &
3832!^ & (rzeta(i-1,j)- &
3833!^ & rzeta(i ,j))+ &
3834!^ & (h(i-1,j)+ &
3835!^ & h(i ,j))* &
3836!^ & (tl_rzeta(i-1,j)- &
3837!^ & tl_rzeta(i ,j))+ &
3838#if defined VAR_RHO_2D && defined SOLVE3D
3839!^ & (tl_h(i-1,j)- &
3840!^ & tl_h(i ,j))* &
3841!^ & (rzetaSA(i-1,j)+ &
3842!^ & rzetaSA(i ,j)+ &
3843!^ & cff2*(rhoA(i-1,j)- &
3844!^ & rhoA(i ,j))* &
3845!^ & (zwrk(i-1,j)- &
3846!^ & zwrk(i ,j)))+ &
3847!^ & (h(i-1,j)- &
3848!^ & h(i ,j))* &
3849!^ & (tl_rzetaSA(i-1,j)+ &
3850!^ & tl_rzetaSA(i ,j)+ &
3851!^ & cff2*((tl_rhoA(i-1,j)- &
3852!^ & tl_rhoA(i ,j))* &
3853!^ & (zwrk(i-1,j)- &
3854!^ & zwrk(i ,j))+ &
3855!^ & (rhoA(i-1,j)- &
3856!^ & rhoA(i ,j))* &
3857!^ & (tl_zwrk(i-1,j)- &
3858!^ & tl_zwrk(i ,j))))+ &
3859#endif
3860!^ & (tl_rzeta2(i-1,j)- &
3861!^ & tl_rzeta2(i ,j)))
3862!^
3863 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
3864 adfac1=adfac*(rzeta(i-1,j)-rzeta(i ,j))
3865 adfac2=adfac*(h(i-1,j)+h(i ,j))
3866 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
3867 ad_h(i ,j)=ad_h(i ,j)+adfac1
3868 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac2
3869 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2
3870 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac
3871 ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac
3872#if defined VAR_RHO_2D && defined SOLVE3D
3873 adfac3=adfac*(rzetasa(i-1,j)+ &
3874 & rzetasa(i ,j)+ &
3875 & cff2*(rhoa(i-1,j)- &
3876 & rhoa(i ,j))* &
3877 & (zwrk(i-1,j)- &
3878 & zwrk(i ,j)))
3879 adfac4=adfac2*cff2*(zwrk(i-1,j)-zwrk(i,j))
3880 adfac5=adfac2*cff2*(rhoa(i-1,j)-rhoa(i,j))
3881 ad_h(i-1,j)=ad_h(i-1,j)+adfac3
3882 ad_h(i ,j)=ad_h(i ,j)-adfac3
3883 ad_rzetasa(i-1,j)=ad_rzetasa(i-1,j)+adfac2
3884 ad_rzetasa(i ,j)=ad_rzetasa(i ,j)+adfac2
3885 ad_rhoa(i-1,j)=ad_rhoa(i-1,j)+adfac4
3886 ad_rhoa(i ,j)=ad_rhoa(i ,j)-adfac4
3887 ad_zwrk(i-1,j)=ad_zwrk(i-1,j)+adfac5
3888 ad_zwrk(i ,j)=ad_zwrk(i ,j)-adfac5
3889#endif
3890 ad_rubar(i,j)=0.0_r8
3891 END IF
3892 END DO
3893 END DO
3894!
3895!-----------------------------------------------------------------------
3896! Adjoint of advance free-surface.
3897!-----------------------------------------------------------------------
3898!
3899! Apply boundary conditions to newly computed free-surface "zeta_new"
3900! and load into global state array. Notice that "zeta_new" is always
3901! centered at time step "m+1", while zeta(:,:,knew) should be centered
3902! either at "m+1/2" after predictor step and at "m+1" after corrector.
3903! Chosing it to be this way makes it possible avoid storing RHS for
3904! zeta, ubar, and vbar between predictor and corrector sub-steps.
3905!
3906 IF (predictor_2d_step) THEN
3907 IF (first_2d_step) THEN
3908 cff1=0.5_r8
3909 cff2=0.5_r8
3910 cff3=0.0_r8
3911 ELSE
3912 cff1=0.5_r8-gamma
3913 cff2=0.5_r8+2.0_r8*gamma
3914 cff3=-gamma
3915 END IF
3916 DO j=jstrr,jendr
3917 DO i=istrr,iendr
3918!^ tl_zeta(i,j,knew)=cff1*tl_zeta_new(i,j)+ &
3919!^ & cff2*tl_zeta(i,j,kstp)+ &
3920!^ & cff3*tl_zeta(i,j,kbak)
3921!^
3922 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff1*ad_zeta(i,j,knew)
3923 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+cff2*ad_zeta(i,j,knew)
3924 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+cff3*ad_zeta(i,j,knew)
3925 ad_zeta(i,j,knew)=0.0_r8
3926 END DO
3927 END DO
3928 ELSE
3929 DO j=jstrr,jendr
3930 DO i=istrr,iendr
3931!^ tl_zeta(i,j,knew)=tl_zeta_new(i,j)
3932!^
3933 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_zeta(i,j,knew)
3934 ad_zeta(i,j,knew)=0.0_r8
3935 END DO
3936 END DO
3937 END IF
3938!
3939! Here, we use the local "zetabc" since the private array "zeta_new"
3940! is passed as an argument to allow computing the lateral boundary
3941! conditions on the range IstrU-1:Iend and JstrV-1:Jend, so parallel
3942! tile exchanges are avoided.
3943!
3944!^ CALL tl_zetabc_local (ng, tile, &
3945!^ & LBi, UBi, LBj, UBj, &
3946!^ & IminS, ImaxS, JminS, JmaxS, &
3947!^ & kstp, &
3948!^ & zeta, tl_zeta, &
3949!^ & zeta_new, tl_zeta_new)
3950!^
3951 CALL ad_zetabc_local (ng, tile, &
3952 & lbi, ubi, lbj, ubj, &
3953 & imins, imaxs, jmins, jmaxs, &
3954 & kstp, &
3955 & zeta, ad_zeta, &
3956 & zeta_new, ad_zeta_new)
3957!
3958! Apply mass point sources (volume vertical influx), if any.
3959!
3960! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
3961!
3962 IF (lwsrc(ng)) THEN
3963 DO is=1,nsrc(ng)
3964 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
3965 i=sources(ng)%Isrc(is)
3966 j=sources(ng)%Jsrc(is)
3967 IF (((istrr.le.i).and.(i.le.iendr)).and. &
3968 & ((jstrr.le.j).and.(j.le.jendr))) THEN
3969!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)+0.0_r8
3970 END IF
3971 END IF
3972 END DO
3973 END IF
3974!
3975! Compute "zeta_new" at the new time step andinterpolate backward for
3976! the subsequent computation of barotropic pressure-gradient terms.
3977! Notice that during the predictor of the first 2D step in 3D mode,
3978! the pressure gradient terms are computed using just zeta(:,:,kstp),
3979! i.e., like in the Forward Euler step, rather than the more accurate
3980! predictor of generalized RK2. This is to keep it consistent with the
3981! computation of pressure gradient in 3D mode, which uses precisely
3982! the initial value of "zeta" rather than the value changed by the
3983! first barotropic predictor step. Later in this code, just after
3984! "rufrc, rvfrc" are finalized, a correction term based on the
3985! difference zeta_new(:,:)-zeta(:,:,kstp) to "rubar, rvbar" to make
3986! them consistent with generalized RK2 stepping for pressure gradient
3987! terms.
3988!
3989 IF (predictor_2d_step) THEN
3990 IF (first_2d_step) THEN ! Modified RK2 time step (with
3991 cff=dtfast(ng) ! Forward-Backward feedback with
3992#ifdef SOLVE3D
3993 cff1=0.0_r8 !==> Forward Euler
3994 cff2=1.0_r8
3995#else
3996 cff1=0.333333333333_r8 ! optimally chosen beta=1/3 and
3997 cff2=0.666666666667_r8 ! epsilon=2/3, see below) is used
3998#endif
3999 cff3=0.0_r8 ! here for the start up.
4000 ELSE
4001 cff=2.0_r8*dtfast(ng) ! In the code below "zwrk" is
4002 cff1=beta ! time-centered at time step "n"
4003 cff2=1.0_r8-2.0_r8*beta ! in the case of LF (for all but
4004 cff3=beta ! the first time step)
4005 END IF
4006!
4007 DO j=jstrv-1,jend
4008 DO i=istru-1,iend
4009 fac=cff*pm(i,j)*pn(i,j)
4010#if defined VAR_RHO_2D && defined SOLVE3D
4011!^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4012!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4013!^
4014 adfac=zwrk(i,j)*ad_rzetasa(i,j)
4015 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4016 & (rhos(i,j)-rhoa(i,j))*ad_rzetasa(i,j)
4017 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4018 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4019 ad_rzetasa(i,j)=0.0_r8
4020!^ tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
4021!^ & rzeta(i,j)*tl_zwrk(i,j)
4022!^
4023 ad_rzeta(i,j)=ad_rzeta(i,j)+zwrk(i,j)*ad_rzeta2(i,j)
4024 ad_zwrk(i,j)=ad_zwrk(i,j)+rzeta(i,j)*ad_rzeta2(i,j)
4025 ad_rzeta2(i,j)=0.0_r8
4026!^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ &
4027!^ & tl_rhoS(i,j)*zwrk(i,j)
4028!^
4029 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_rzeta(i,j)
4030 ad_zwrk(i,j)=ad_zwrk(i,j)+(1.0_r8+rhos(i,j))*ad_rzeta(i,j)
4031 ad_rzeta(i,j)=0.0_r8
4032#else
4033!^ tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4034!^ tl_rzeta(i,j)=tl_zwrk(i,j)
4035!^
4036 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4037 & 2.0_r8*zwrk(i,j)*ad_rzeta2(i,j)+ &
4038 & ad_rzeta(i,j)
4039#endif
4040!^ tl_zwrk(i,j)=cff1*tl_zeta_new(i,j)+ &
4041!^ & cff2*tl_zeta(i,j,kstp)+ &
4042!^ & cff3*tl_zeta(i,j,kbak)
4043!^
4044 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff1*ad_zwrk(i,j)
4045 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+cff2*ad_zwrk(i,j)
4046 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+cff3*ad_zwrk(i,j)
4047 ad_zwrk(i,j)=0.0_r8
4048!^ tl_Dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
4049!^
4050 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
4051 ad_dnew(i,j)=0.0_r8
4052#ifdef MASKING
4053# ifdef WET_DRY_NOT_YET
4054!! zeta_new(i,j)=zeta_new(i,j)+ &
4055!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
4056# endif
4057!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4058!^
4059 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4060#endif
4061!^ tl_zeta_new(i,j)=tl_zeta(i,j,kbak)+ &
4062!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
4063!^ & DVom(i,j)-DVom(i,j+1))
4064!^
4065 adfac=fac*ad_zeta_new(i,j)
4066 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+ad_zeta_new(i,j)
4067 ad_duon(i ,j)=ad_duon(i ,j)+adfac
4068 ad_duon(i+1,j)=ad_duon(i+1,j)-adfac
4069 ad_dvom(i,j )=ad_dvom(i,j )+adfac
4070 ad_dvom(i,j+1)=ad_dvom(i,j+1)-adfac
4071 ad_zeta_new(i,j)=0.0_r8
4072 END DO
4073 END DO
4074 ELSE !--> CORRECTOR STEP
4075 IF (first_2d_step) THEN
4076 cff =0.333333333333_r8 ! Modified RK2 weighting:
4077 cff1=0.333333333333_r8 ! here "zwrk" is time-
4078 cff2=0.333333333333_r8 ! centered at "n+1/2".
4079 cff3=0.0_r8
4080 ELSE
4081 cff =1.0_r8-epsil ! zwrk is always time-
4082 cff1=(0.5_r8-gamma)*epsil ! centered at n+1/2
4083 cff2=(0.5_r8+2.0_r8*gamma)*epsil ! during corrector sub-
4084 cff3=-gamma *epsil ! step.
4085 END IF
4086!
4087 DO j=jstrv-1,jend
4088 DO i=istru-1,iend
4089 fac=dtfast(ng)*pm(i,j)*pn(i,j)
4090#if defined VAR_RHO_2D && defined SOLVE3D
4091!^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4092!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4093!^
4094 adfac=zwrk(i,j)*ad_rzetasa(i,j)
4095 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4096 & (rhos(i,j)-rhoa(i,j))*ad_rzetasa(i,j)
4097 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4098 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4099 ad_rzetasa(i,j)=0.0_r8
4100!^ tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
4101!^ & rzeta(i,j)*tl_zwrk(i,j)
4102!^
4103 ad_rzeta(i,j)=ad_rzeta(i,j)+zwrk(i,j)*ad_rzeta2(i,j)
4104 ad_zwrk(i,j)=ad_zwrk(i,j)+rzeta(i,j)*ad_rzeta2(i,j)
4105 ad_rzeta2(i,j)=0.0_r8
4106!^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ &
4107!^ & tl_rhoS(i,j)*zwrk(i,j)
4108!^
4109 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_rzeta(i,j)
4110 ad_zwrk(i,j)=ad_zwrk(i,j)+(1.0_r8+rhos(i,j))*ad_rzeta(i,j)
4111 ad_rzeta(i,j)=0.0_r8
4112#else
4113!^ tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4114!^ tl_rzeta(i,j)=tl_zwrk(i,j)
4115!^
4116 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4117 & 2.0_r8*zwrk(i,j)*ad_rzeta2(i,j)+ &
4118 & ad_rzeta(i,j)
4119#endif
4120!^ tl_zwrk(i,j)=cff *tl_zeta(i,j,krhs)+ &
4121!^ & cff1*tl_zeta_new(i,j)+ &
4122!^ & cff2*tl_zeta(i,j,kstp)+ &
4123!^ & cff3*tl_zeta(i,j,kbak)
4124!^
4125 ad_zeta_new(i,j)=ad_zeta_new(i,j)+cff1*ad_zwrk(i,j)
4126 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+cff *ad_zwrk(i,j)
4127 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+cff2*ad_zwrk(i,j)
4128 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+cff3*ad_zwrk(i,j)
4129 ad_zwrk(i,j)=0.0_r8
4130!^ tl_Dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
4131!^
4132 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
4133 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_dnew(i,j)
4134 ad_dnew(i,j)=0.0_r8
4135#ifdef MASKING
4136# ifdef WET_DRY_NOT_YET
4137!! zeta_new(i,j)=zeta_new(i,j)+ &
4138!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
4139# endif
4140!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4141!^
4142 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4143#endif
4144!^ tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
4145!^ & fac*(tl_DUon(i,j)-tl_DUon(i+1,j)+ &
4146!^ & tl_DVom(i,j)-tl_DVom(i,j+1))
4147!^
4148 adfac=fac*ad_zeta_new(i,j)
4149 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_zeta_new(i,j)
4150 ad_duon(i ,j)=ad_duon(i ,j)+adfac
4151 ad_duon(i+1,j)=ad_duon(i+1,j)-adfac
4152 ad_dvom(i,j )=ad_dvom(i,j )+adfac
4153 ad_dvom(i,j+1)=ad_dvom(i,j+1)-adfac
4154 ad_zeta_new(i,j)=0.0_r8
4155 END DO
4156 END DO
4157 END IF
4158
4159#ifdef SOLVE3D
4160!
4161!-----------------------------------------------------------------------
4162! Adjoint of fields averaged over all barotropic time steps.
4163!-----------------------------------------------------------------------
4164!
4165! Notice that the index ranges here are designed to include physical
4166! boundaries only. Periodic ghost points and internal mpi computational
4167! margins are NOT included.
4168!
4169! Reset all barotropic mode time-averaged arrays during the first
4170! predictor step. At all subsequent time steps, accumulate averages
4171! of the first kind using the DELAYED way. For example, "Zt_avg1" is
4172! not summed immediately after the corrector step when computed but
4173! during the subsequent predictor substep. It allows saving operations
4174! because "DUon" and "DVom" are calculated anyway. The last time step
4175! has a special code to add all three barotropic variables after the
4176! last corrector substep.
4177!
4178 IF (predictor_2d_step) THEN ! PREDICTOR STEP
4179 IF (first_2d_step) THEN
4180 DO j=jstrr,jendr
4181 DO i=istrr,iendr
4182!^ tl_DV_avg2(i,j)=0.0_r8
4183!^
4184 ad_dv_avg2(i,j)=0.0_r8
4185!^ tl_DU_avg2(i,j)=0.0_r8
4186!^
4187 ad_du_avg2(i,j)=0.0_r8
4188!^ tl_DV_avg1(i,j)=0.0_r8
4189!^
4190 ad_dv_avg1(i,j)=0.0_r8
4191!^ tl_DU_avg1(i,j)=0.0_r8
4192!^
4193 ad_du_avg1(i,j)=0.0_r8
4194!^ tl_Zt_avg1(i,j)=0.0_r8
4195!^
4196 ad_zt_avg1(i,j)=0.0_r8
4197 END DO
4198 END DO
4199 ELSE
4200 cff=weight(1,iif(ng)-1,ng)
4201 DO j=jstrr,jendr
4202 DO i=istrr,iendr
4203 IF (j.ge.jstr) THEN
4204!^ tl_DV_avg1(i,j)=tl_DV_avg1(i,j)+cff*tl_DVom(i,j)
4205!^
4206 ad_dvom(i,j)=ad_dvom(i,j)+cff*ad_dv_avg1(i,j)
4207 END IF
4208 IF (i.ge.istr) THEN
4209!^ tl_DU_avg1(i,j)=tl_DU_avg1(i,j)+cff*tl_DUon(i,j)
4210!^
4211 ad_duon(i,j)=ad_duon(i,j)+cff*ad_du_avg1(i,j)
4212 END IF
4213!^ tl_Zt_avg1(i,j)=tl_Zt_avg1(i,j)+cff*tl_zeta(i,j,krhs)
4214!^
4215 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+cff*ad_zt_avg1(i,j)
4216 END DO
4217 END DO
4218 END IF
4219 ELSE ! CORRECTOR STEP
4220 cff=weight(2,iif(ng),ng)
4221 DO j=jstrr,jendr
4222 DO i=istrr,iendr
4223 IF (j.ge.jstr) THEN
4224!^ tl_DV_avg2(i,j)=tl_DV_avg2(i,j)+cff*tl_DVom(i,j)
4225!^
4226 ad_dvom(i,j)=ad_dvom(i,j)+cff*ad_dv_avg2(i,j)
4227 END IF
4228 IF (i.ge.istr) THEN
4229!^ tl_DU_avg2(i,j)=tl_DU_avg2(i,j)+cff*tl_DUon(i,j)
4230!^
4231 ad_duon(i,j)=ad_duon(i,j)+cff*ad_du_avg2(i,j)
4232 END IF
4233 END DO
4234 END DO
4235 END IF
4236#endif
4237!
4238!-----------------------------------------------------------------------
4239! Adjoint of preliminary steps.
4240!-----------------------------------------------------------------------
4241!
4242! Set vertically integrated mass fluxes DUon and DVom along the open
4243! boundaries in such a way that the integral volume is conserved.
4244!
4245 IF (any(volcons(:,ng))) THEN
4246!^ CALL tl_set_DUV_bc_tile (ng, tile, &
4247!^ & LBi, UBi, LBj, UBj, &
4248!^ & IminS, ImaxS, JminS, JmaxS, &
4249!^ & krhs, &
4250#ifdef MASKING
4251!^ & umask, vmask, &
4252#endif
4253!^ & om_v, on_u, &
4254!^ & ubar, vbar, &
4255!^ & tl_ubar, tl_vbar, &
4256!^ & Drhs, DUon, DVom, &
4257!^ & tl_Drhs, tl_DUon, tl_DVom)
4258!^
4259 CALL ad_set_duv_bc_tile (ng, tile, &
4260 & lbi, ubi, lbj, ubj, &
4261 & imins, imaxs, jmins, jmaxs, &
4262 & krhs, &
4263#ifdef MASKING
4264 & umask, vmask, &
4265#endif
4266 & om_v, on_u, &
4267 & ubar, vbar, &
4268 & ad_ubar, ad_vbar, &
4269 & drhs, duon, dvom, &
4270 & ad_drhs, ad_duon, ad_dvom)
4271 END IF
4272
4273#if defined DISTRIBUTE && \
4274 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
4275!
4276! In distributed-memory, the I- and J-ranges are different and a
4277! special exchange is done here to avoid having three ghost points
4278! for high-order numerical stencils. Notice that a private array is
4279! passed below to the exchange routine. It also applies periodic
4280! boundary conditions, if appropriate and no partitions in I- or
4281! J-directions.
4282!
4283!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
4284!^ & IminS, ImaxS, JminS, JmaxS, &
4285!^ & NghostPoints, &
4286!^ & EWperiodic(ng), NSperiodic(ng), &
4287!^ & DUon, DVom, &
4288!^ & tl_DUon, tl_DVom)
4289!^
4290 CALL ad_mp_exchange2d (ng, tile, itlm, 2, &
4291 & imins, imaxs, jmins, jmaxs, &
4292 & nghostpoints, &
4293 & ewperiodic(ng), nsperiodic(ng), &
4294 & ad_duon, ad_dvom)
4295!
4296 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
4297!^ CALL exchange_v2d_tile (ng, tile, &
4298!^ & IminS, ImaxS, JminS, JmaxS, &
4299!^ & tl_DVom)
4300!^
4301 CALL ad_exchange_v2d_tile (ng, tile, &
4302 & imins, imaxs, jmins, jmaxs, &
4303 & ad_dvom)
4304!^ CALL exchange_u2d_tile (ng, tile, &
4305!^ & IminS, ImaxS, JminS, JmaxS, &
4306!^ & tl_DUon)
4307!^
4308 CALL ad_exchange_u2d_tile (ng, tile, &
4309 & imins, imaxs, jmins, jmaxs, &
4310 & ad_duon)
4311
4312 END IF
4313#endif
4314!
4315! Compute total depth of the water column and vertically integrated
4316! mass fluxes, which are used in computation of free-surface elevation
4317! time tendency and advection terms for the barotropic momentum
4318! equations.
4319!
4320#if defined DISTRIBUTE && !defined NESTING
4321# define IR_RANGE IstrUm2-1,Iendp2
4322# define JR_RANGE JstrVm2-1,Jendp2
4323# define IU_RANGE IstrUm1-1,Iendp2
4324# define JU_RANGE Jstrm1-1,Jendp2
4325# define IV_RANGE Istrm1-1,Iendp2
4326# define JV_RANGE JstrVm1-1,Jendp2
4327#else
4328# define IR_RANGE IstrUm2-1,Iendp2
4329# define JR_RANGE JstrVm2-1,Jendp2
4330# define IU_RANGE IstrUm2,Iendp2
4331# define JU_RANGE JstrVm2-1,Jendp2
4332# define IV_RANGE IstrUm2-1,Iendp2
4333# define JV_RANGE JstrVm2,Jendp2
4334#endif
4335
4336 DO j=jv_range
4337 DO i=iv_range
4338 cff=0.5_r8*om_v(i,j)
4339 cff1=cff*(drhs(i,j)+drhs(i,j-1))
4340!^ tl_DVom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
4341!^ & vbar(i,j,krhs)*tl_cff1
4342!^
4343 ad_vbar(i,j,krhs)=ad_vbar(i,j,krhs)+cff1*ad_dvom(i,j)
4344 ad_cff1=ad_cff1+vbar(i,j,krhs)*ad_dvom(i,j)
4345 ad_dvom(i,j)=0.0_r8
4346!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i,j-1))
4347!^
4348 adfac=cff*ad_cff1
4349 ad_drhs(i,j-1)=ad_drhs(i,j-1)+adfac
4350 ad_drhs(i,j )=ad_drhs(i,j )+adfac
4351 ad_cff1=0.0_r8
4352 END DO
4353 END DO
4354 DO j=ju_range
4355 DO i=iu_range
4356 cff=0.5_r8*on_u(i,j)
4357 cff1=cff*(drhs(i,j)+drhs(i-1,j))
4358!^ tl_DUon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
4359!^ & ubar(i,j,krhs)*tl_cff1
4360!^
4361 ad_ubar(i,j,krhs)=ad_ubar(i,j,krhs)+cff1*ad_duon(i,j)
4362 ad_cff1=ad_cff1+ubar(i,j,krhs)*ad_duon(i,j)
4363 ad_duon(i,j)=0.0_r8
4364!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i-1,j))
4365!^
4366 adfac=cff*ad_cff1
4367 ad_drhs(i-1,j)=ad_drhs(i-1,j)+adfac
4368 ad_drhs(i ,j)=ad_drhs(i ,j)+adfac
4369 ad_cff1=0.0_r8
4370 END DO
4371 END DO
4372 DO j=jr_range
4373 DO i=ir_range
4374!^ tl_Drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
4375!^
4376 ad_h(i,j)=ad_h(i,j)+ad_drhs(i,j)
4377 ad_zeta(i,j,krhs)=ad_zeta(i,j,krhs)+ad_drhs(i,j)
4378 ad_drhs(i,j)=0.0_r8
4379 END DO
4380 END DO
4381
4382#undef IR_RANGE
4383#undef IU_RANGE
4384#undef IV_RANGE
4385#undef JR_RANGE
4386#undef JU_RANGE
4387#undef JV_RANGE
4388!
4389! Deallocate local new free-surface.
4390!
4391 deallocate ( ad_zeta_new )
4392!
4393 RETURN

References ad_exchange_2d_mod::ad_exchange_r2d_tile(), ad_exchange_2d_mod::ad_exchange_u2d_tile(), ad_exchange_2d_mod::ad_exchange_v2d_tile(), mp_exchange_mod::ad_mp_exchange2d(), ad_obc_volcons_mod::ad_obc_flux_tile(), ad_set_depth_mod::ad_set_depth(), ad_obc_volcons_mod::ad_set_duv_bc_tile(), ad_u2dbc_mod::ad_u2dbc_tile(), ad_v2dbc_mod::ad_v2dbc_tile(), mod_scalars::compositegrid, mod_param::domain, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_param::iadm, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_param::inlm, mod_scalars::inorth, mod_scalars::isouth, mod_param::itlm, mod_scalars::iwest, mod_scalars::luvsrc, mod_scalars::lwsrc, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, obc_volcons_mod::obc_flux_tile(), mod_scalars::predictor_2d_step, mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, mod_scalars::volcons, and mod_scalars::weight.

Here is the call graph for this function:

◆ ad_step2d_tile() [2/3]

subroutine ad_step2d_mod::ad_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) krhs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) omn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(inout) ad_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_bustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk,2), intent(inout) ad_ru,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk,2), intent(inout) ad_rv,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_ubar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_vbar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_zeta_sol,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rzeta,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rzeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_zeta )
private

Definition at line 168 of file ad_step2d_LF_AM3.h.

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
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_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_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_param
Definition mod_param.F:2
mod_param::ad_lbc
type(t_lbc), dimension(:,:,:), allocatable ad_lbc
Definition mod_param.F:378
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_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
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

References ad_exchange_2d_mod::ad_exchange_r2d_tile(), ad_exchange_2d_mod::ad_exchange_u2d_tile(), ad_exchange_2d_mod::ad_exchange_v2d_tile(), mod_param::ad_lbc, mp_exchange_mod::ad_mp_exchange2d(), ad_obc_volcons_mod::ad_obc_flux_tile(), ad_obc_volcons_mod::ad_set_duv_bc_tile(), ad_u2dbc_mod::ad_u2dbc_tile(), ad_v2dbc_mod::ad_v2dbc_tile(), mod_scalars::ad_volcons, ad_zetabc_mod::ad_zetabc_tile(), mod_clima::clima, mod_scalars::compositegrid, mod_param::domain, mod_scalars::dt, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_scalars::gamma2, mod_param::iadm, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_scalars::inorth, mod_scalars::isouth, mod_ncparam::isubar, mod_ncparam::isvbar, mod_scalars::iwest, mod_scalars::lnudgem2clm, mod_scalars::luvsrc, mod_scalars::lwsrc, mp_exchange_mod::mp_exchange2d(), mod_scalars::ndtfast, mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, mod_scalars::ntfirst, obc_volcons_mod::obc_flux_tile(), mod_scalars::predictor_2d_step, mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, and mod_scalars::weight.

Here is the call graph for this function:

◆ ad_step2d_tile() [3/3]

subroutine ad_step2d_mod::ad_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) krhs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rdrag,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rdrag2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(in) ad_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_eq_tide,
sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_sustr,
svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rufrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) ad_rvfrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_du_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) ad_dv_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_ubar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_vbar_sol,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) ad_zeta_sol,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) ad_zeta )
private

Definition at line 213 of file ad_step2d_FB.h.

301!***********************************************************************
302!
303! Imported variable declarations.
304!
305 integer, intent(in ) :: ng, tile
306 integer, intent(in ) :: LBi, UBi, LBj, UBj, UBk
307 integer, intent(in ) :: IminS, ImaxS, JminS, JmaxS
308 integer, intent(in ) :: krhs, kstp, knew
309#ifdef SOLVE3D
310 integer, intent(in ) :: nstp, nnew
311#endif
312!
313#ifdef ASSUMED_SHAPE
314# ifdef MASKING
315 real(r8), intent(in ) :: pmask(LBi:,LBj:)
316 real(r8), intent(in ) :: rmask(LBi:,LBj:)
317 real(r8), intent(in ) :: umask(LBi:,LBj:)
318 real(r8), intent(in ) :: vmask(LBi:,LBj:)
319# endif
320# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
321 real(r8), intent(in ) :: fomn(LBi:,LBj:)
322# endif
323 real(r8), intent(in ) :: h(LBi:,LBj:)
324 real(r8), intent(in ) :: om_u(LBi:,LBj:)
325 real(r8), intent(in ) :: om_v(LBi:,LBj:)
326 real(r8), intent(in ) :: on_u(LBi:,LBj:)
327 real(r8), intent(in ) :: on_v(LBi:,LBj:)
328 real(r8), intent(in ) :: pm(LBi:,LBj:)
329 real(r8), intent(in ) :: pn(LBi:,LBj:)
330# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
331 real(r8), intent(in ) :: dndx(LBi:,LBj:)
332 real(r8), intent(in ) :: dmde(LBi:,LBj:)
333# endif
334 real(r8), intent(in ) :: rdrag(LBi:,LBj:)
335# if defined UV_QDRAG && !defined SOLVE3D
336 real(r8), intent(in ) :: rdrag2(LBi:,LBj:)
337# endif
338 real(r8), intent(in ) :: rufrc(LBi:,LBj:)
339 real(r8), intent(in ) :: rvfrc(LBi:,LBj:)
340# if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
341 real(r8), intent(in ) :: pmon_r(LBi:,LBj:)
342 real(r8), intent(in ) :: pnom_r(LBi:,LBj:)
343 real(r8), intent(in ) :: pmon_p(LBi:,LBj:)
344 real(r8), intent(in ) :: pnom_p(LBi:,LBj:)
345 real(r8), intent(in ) :: om_r(LBi:,LBj:)
346 real(r8), intent(in ) :: on_r(LBi:,LBj:)
347 real(r8), intent(in ) :: om_p(LBi:,LBj:)
348 real(r8), intent(in ) :: on_p(LBi:,LBj:)
349# ifdef UV_VIS2
350 real(r8), intent(in ) :: visc2_p(LBi:,LBj:)
351 real(r8), intent(in ) :: visc2_r(LBi:,LBj:)
352# endif
353# ifdef UV_VIS4
354 real(r8), intent(in ) :: visc4_p(LBi:,LBj:)
355 real(r8), intent(in ) :: visc4_r(LBi:,LBj:)
356# endif
357# endif
358# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
359 real(r8), intent(inout) :: ad_bed_thick(LBi:,LBj:,:)
360# endif
361# ifdef WEC_MELLOR
362 real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:)
363 real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:)
364# endif
365# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
366 real(r8), intent(in ) :: eq_tide(LBi:,LBj:)
367 real(r8), intent(inout) :: ad_eq_tide(LBi:,LBj:)
368# endif
369 real(r8), intent(in ) :: ubar(LBi:,LBj:,:)
370 real(r8), intent(in ) :: vbar(LBi:,LBj:,:)
371 real(r8), intent(in ) :: zeta(LBi:,LBj:,:)
372 real(r8), intent(inout) :: ad_h(LBi:,LBj:)
373# ifndef SOLVE3D
374 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
375 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
376# ifdef ATM_PRESS
377 real(r8), intent(in ) :: Pair(LBi:,LBj:)
378# endif
379# else
380# ifdef VAR_RHO_2D
381 real(r8), intent(in ) :: rhoA(LBi:,LBj:)
382 real(r8), intent(in ) :: rhoS(LBi:,LBj:)
383 real(r8), intent(inout) :: ad_rhoA(LBi:,LBj:)
384 real(r8), intent(inout) :: ad_rhoS(LBi:,LBj:)
385# endif
386 real(r8), intent(inout) :: ad_DU_avg1(LBi:,LBj:)
387 real(r8), intent(inout) :: ad_DU_avg2(LBi:,LBj:)
388 real(r8), intent(inout) :: ad_DV_avg1(LBi:,LBj:)
389 real(r8), intent(inout) :: ad_DV_avg2(LBi:,LBj:)
390 real(r8), intent(inout) :: ad_Zt_avg1(LBi:,LBj:)
391 real(r8), intent(inout) :: ad_rufrc(LBi:,LBj:)
392 real(r8), intent(inout) :: ad_rvfrc(LBi:,LBj:)
393 real(r8), intent(inout) :: ad_rufrc_bak(LBi:,LBj:,:)
394 real(r8), intent(inout) :: ad_rvfrc_bak(LBi:,LBj:,:)
395# endif
396# ifdef WEC_MELLOR
397 real(r8), intent(inout) :: ad_rustr2d(LBi:,LBj:)
398 real(r8), intent(inout) :: ad_rvstr2d(LBi:,LBj:)
399 real(r8), intent(inout) :: ad_rulag2d(LBi:,LBj:)
400 real(r8), intent(inout) :: ad_rvlag2d(LBi:,LBj:)
401 real(r8), intent(inout) :: ad_ubar_stokes(LBi:,LBj:)
402 real(r8), intent(inout) :: ad_vbar_stokes(LBi:,LBj:)
403# endif
404# ifdef WET_DRY_NOT_YET
405 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
406 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
407 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
408 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
409
410 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
411 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
412 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
413 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
414# ifdef SOLVE3D
415 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
416# endif
417# endif
418# ifdef DIAGNOSTICS_UV
419!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
420!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
421!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
422!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
423# ifdef SOLVE3D
424!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
425!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
426!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
427!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
428# endif
429# endif
430 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
431 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
432 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
433# if defined NESTING && !defined SOLVE3D
434 real(r8), intent(inout) :: ad_DU_flux(LBi:,LBj:)
435 real(r8), intent(inout) :: ad_DV_flux(LBi:,LBj:)
436# endif
437 real(r8), intent(out ) :: ad_ubar_sol(LBi:,LBj:)
438 real(r8), intent(out ) :: ad_vbar_sol(LBi:,LBj:)
439 real(r8), intent(out ) :: ad_zeta_sol(LBi:,LBj:)
440
441#else
442
443# ifdef MASKING
444 real(r8), intent(in ) :: pmask(LBi:UBi,LBj:UBj)
445 real(r8), intent(in ) :: rmask(LBi:UBi,LBj:UBj)
446 real(r8), intent(in ) :: umask(LBi:UBi,LBj:UBj)
447 real(r8), intent(in ) :: vmask(LBi:UBi,LBj:UBj)
448# endif
449# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
450 real(r8), intent(in ) :: fomn(LBi:UBi,LBj:UBj)
451# endif
452 real(r8), intent(in ) :: h(LBi:UBi,LBj:UBj)
453 real(r8), intent(in ) :: om_u(LBi:UBi,LBj:UBj)
454 real(r8), intent(in ) :: om_v(LBi:UBi,LBj:UBj)
455 real(r8), intent(in ) :: on_u(LBi:UBi,LBj:UBj)
456 real(r8), intent(in ) :: on_v(LBi:UBi,LBj:UBj)
457 real(r8), intent(in ) :: pm(LBi:UBi,LBj:UBj)
458 real(r8), intent(in ) :: pn(LBi:UBi,LBj:UBj)
459# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
460 real(r8), intent(in ) :: dndx(LBi:UBi,LBj:UBj)
461 real(r8), intent(in ) :: dmde(LBi:UBi,LBj:UBj)
462# endif
463 real(r8), intent(in ) :: rdrag(LBi:UBi,LBj:UBj)
464# if defined UV_QDRAG && !defined SOLVE3D
465 real(r8), intent(in ) :: rdrag2(LBi:UBi,LBj:UBj)
466# endif
467 real(r8), intent(in ) :: rufrc(LBi:UBi,LBj:UBj)
468 real(r8), intent(in ) :: rvfrc(LBi:UBi,LBj:UBj)
469# if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
470 real(r8), intent(in ) :: pmon_r(LBi:UBi,LBj:UBj)
471 real(r8), intent(in ) :: pnom_r(LBi:UBi,LBj:UBj)
472 real(r8), intent(in ) :: pmon_p(LBi:UBi,LBj:UBj)
473 real(r8), intent(in ) :: pnom_p(LBi:UBi,LBj:UBj)
474 real(r8), intent(in ) :: om_r(LBi:UBi,LBj:UBj)
475 real(r8), intent(in ) :: on_r(LBi:UBi,LBj:UBj)
476 real(r8), intent(in ) :: om_p(LBi:UBi,LBj:UBj)
477 real(r8), intent(in ) :: on_p(LBi:UBi,LBj:UBj)
478# ifdef UV_VIS2
479 real(r8), intent(in ) :: visc2_p(LBi:UBi,LBj:UBj)
480 real(r8), intent(in ) :: visc2_r(LBi:UBi,LBj:UBj)
481# endif
482# ifdef UV_VIS4
483 real(r8), intent(in ) :: visc4_p(LBi:UBi,LBj:UBj)
484 real(r8), intent(in ) :: visc4_r(LBi:UBi,LBj:UBj)
485# endif
486# endif
487# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
488 real(r8), intent(in ) :: ad_bed_thick(LBi:UBi,LBj:UBj,3)
489# endif
490# ifdef WEC_MELLOR
491 real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj)
492 real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj)
493# endif
494# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
495 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
496 real(r8), intent(inout) :: ad_eq_tide(LBi:UBi,LBj:UBj)
497# endif
498 real(r8), intent(in ) :: ubar(LBi:UBi,LBj:UBj,:)
499 real(r8), intent(in ) :: vbar(LBi:UBi,LBj:UBj,:)
500 real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:)
501 real(r8), intent(inout) :: ad_h(LBi:UBi,LBj:UBj)
502# ifndef SOLVE3D
503 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
504 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
505# ifdef ATM_PRESS
506 real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj)
507# endif
508# else
509# ifdef VAR_RHO_2D
510 real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj)
511 real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj)
512 real(r8), intent(inout) :: ad_rhoA(LBi:UBi,LBj:UBj)
513 real(r8), intent(inout) :: ad_rhoS(LBi:UBi,LBj:UBj)
514# endif
515 real(r8), intent(inout) :: ad_DU_avg1(LBi:UBi,LBj:UBj)
516 real(r8), intent(inout) :: ad_DU_avg2(LBi:UBi,LBj:UBj)
517 real(r8), intent(inout) :: ad_DV_avg1(LBi:UBi,LBj:UBj)
518 real(r8), intent(inout) :: ad_DV_avg2(LBi:UBi,LBj:UBj)
519 real(r8), intent(inout) :: ad_Zt_avg1(LBi:UBi,LBj:UBj)
520 real(r8), intent(inout) :: ad_rufrc(LBi:UBi,LBj:UBj)
521 real(r8), intent(inout) :: ad_rvfrc(LBi:UBi,LBj:UBj)
522 real(r8), intent(inout) :: ad_rufrc_bak(LBi:UBi,LBj:UBj,2)
523 real(r8), intent(inout) :: ad_rvfrc_bak(LBi:UBi,LBj:UBj,2)
524# endif
525# ifdef WEC_MELLOR
526 real(r8), intent(inout) :: ad_rustr2d(LBi:UBi,LBj:UBj)
527 real(r8), intent(inout) :: ad_rvstr2d(LBi:UBi,LBj:UBj)
528 real(r8), intent(inout) :: ad_rulag2d(LBi:UBi,LBj:UBj)
529 real(r8), intent(inout) :: ad_rvlag2d(LBi:UBi,LBj:UBj)
530 real(r8), intent(inout) :: ad_ubar_stokes(LBi:UBi,LBj:UBj)
531 real(r8), intent(inout) :: ad_vbar_stokes(LBi:UBi,LBj:UBj)
532# endif
533# ifdef WET_DRY_NOT_YET
534 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
535 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
536 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
537 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
538
539 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
540 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
541 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
542 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
543# ifdef SOLVE3D
544 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
545# endif
546# endif
547# ifdef DIAGNOSTICS_UV
548!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
549!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
550!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
551!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
552# ifdef SOLVE3D
553!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
554!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
555!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
556!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
557# endif
558# endif
559 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
560 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
561 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
562# if defined NESTING && !defined SOLVE3D
563 real(r8), intent(inout) :: ad_DU_flux(LBi:UBi,LBj:UBj)
564 real(r8), intent(inout) :: ad_DV_flux(LBi:UBi,LBj:UBj)
565# endif
566 real(r8), intent(out ) :: ad_ubar_sol(LBi:UBi,LBj:UBj)
567 real(r8), intent(out ) :: ad_vbar_sol(LBi:UBi,LBj:UBj)
568 real(r8), intent(out ) :: ad_zeta_sol(LBi:UBi,LBj:UBj)
569#endif
570!
571! Local variable declarations.
572!
573 integer :: i, is, j
574 integer :: kbak, kold
575#ifdef DIAGNOSTICS_UV
576 integer :: idiag
577#endif
578!
579 real(r8) :: bkw0, bkw1, bkw2, bkw_new
580 real(r8) :: fwd0, fwd1, fwd2
581#ifdef SOLVE3D
582 real(r8) :: cfwd0, cfwd1, cfwd2
583#endif
584 real(r8) :: cff, cff1, cff2, cff3, cff4
585#ifdef WET_DRY_NOT_YET
586 real(r8) :: cff5, cff6, cff7
587#endif
588 real(r8) :: fac, fac1, fac2
589 real(r8) :: ad_cff, ad_cff1, ad_cff2, ad_cff3, ad_cff4
590#ifdef WET_DRY_NOT_YET
591 real(r8) :: ad_cff5, ad_cff6, ad_cff7
592#endif
593 real(r8) :: ad_fac, ad_fac1, ad_fac2
594 real(r8) :: adfac, adfac1, adfac2, adfac3, adfac4, adfac5
595!
596 real(r8), parameter :: IniVal = 0.0_r8
597!
598#if defined UV_C4ADVECTION && !defined SOLVE3D
599 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
600#endif
601 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
602 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew_rd
603 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
604#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
605 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
606#endif
607 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
608 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
609 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
610#ifdef WEC_MELLOR
611 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
612 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
613#endif
614#if defined UV_C4ADVECTION && !defined SOLVE3D
615 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
616#endif
617 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2
618#if defined VAR_RHO_2D && defined SOLVE3D
619 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA
620#endif
621 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar
622 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar
623 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta
624 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: urhs
625 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: vrhs
626 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
627 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
628#ifdef WET_DRY_NOT_YET
629 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
630#endif
631#ifdef DIAGNOSTICS_UV
632!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
633!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
634!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaU2rhs
635!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaV2rhs
636#endif
637!
638#if defined UV_C4ADVECTION && !defined SOLVE3D
639 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dgrad
640#endif
641 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dnew
642 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dnew_rd
643 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs
644#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
645 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Drhs_p
646#endif
647 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Dstp
648 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUon
649 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVom
650#ifdef WEC_MELLOR
651 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DUSon
652 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_DVSom
653#endif
654#if defined STEP2D_CORIOLIS || !defined SOLVE3D
655 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFx
656 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFe
657#endif
658#if !defined SOLVE3D
659 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFe
660 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFx
661#endif
662#if defined UV_C4ADVECTION && !defined SOLVE3D
663 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad
664#endif
665 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta2
666#if defined VAR_RHO_2D && defined SOLVE3D
667 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzetaSA
668#endif
669 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta
670 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rubar
671 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rvbar
672 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_urhs
673 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_vrhs
674 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_zwrk
675!
676 real(r8), allocatable :: ad_zeta_new(:,:)
677
678#include "set_bounds.h"
679!
680!-----------------------------------------------------------------------
681! Initialize adjoint private variables.
682!-----------------------------------------------------------------------
683!
684 ad_cff=inival
685 ad_cff1=inival
686 ad_cff2=inival
687 ad_cff3=inival
688 ad_cff4=inival
689 ad_fac=inival
690 ad_fac1=inival
691 ad_fac2=inival
692!
693#if defined UV_C4ADVECTION && !defined SOLVE3D
694 ad_dgrad=inival
695#endif
696 ad_dnew=inival
697 ad_dnew_rd=inival
698 ad_drhs=inival
699#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
700 ad_drhs_p=inival
701#endif
702 ad_dstp=inival
703 ad_duon=inival
704 ad_dvom=inival
705#ifdef WEC_MELLOR
706 ad_duson=inival
707 ad_dvsom=inival
708#endif
709#if defined STEP2D_CORIOLIS || !defined SOLVE3D
710 ad_ufx=inival
711 ad_vfe=inival
712#endif
713#if !defined SOLVE3D
714 ad_ufe=inival
715 ad_vfx=inival
716#endif
717#if defined UV_C4ADVECTION && !defined SOLVE3D
718 ad_grad=inival
719#endif
720 ad_rzeta2=inival
721#if defined VAR_RHO_2D && defined SOLVE3D
722 ad_rzetasa=inival
723#endif
724 ad_rzeta=inival
725 ad_rubar=inival
726 ad_rvbar=inival
727 ad_urhs=inival
728 ad_vrhs=inival
729 ad_zwrk=inival
730!
731!-----------------------------------------------------------------------
732! Set coefficients for AB3-AM4 forward-backward algorithm.
733!-----------------------------------------------------------------------
734!
735! Because the Forward Euler step is used to update "zeta" during the
736! first barotropic step, the pressure-gradient term in the momentum
737! equation must be computed via the Backward step to keep it
738! numerically stable. However, this interferes with the computation
739! of forcing terms "rufrc" and "rvfrc" because the free surface in
740! pressure gradient computation in 3D is exactly at the time
741! corresponding to baroclinic step "nstp" (rather than ahead by one
742! barotropic step after it updated by a normal forward-backward step).
743! To resolve this conflict, the pressure gradient term is computed in
744! two stages during the first barotropic step. It uses zeta(:,:,kstp)
745! at first to ensure exact consistency with 3D model. Then, after
746! vertical integrals of 3D right-hand-side "rufrc" and "rvfrc" are
747! converted into forcing terms, add correction based on the difference
748! zeta_new(:,:)-zeta(:,:,kstp) to "rubar" and "rvbar" to make them
749! consistent with the Backward step for pressure gradient.
750! For pressure gradient terms, search for the label PGF_FB_CORRECTION
751! below.
752!
753 IF (first_2d_step) THEN ! Meaning of time indices
754 kbak=kstp !------------------------
755 kold=kstp ! m-2 m-1 m m+1
756 fwd0=1.0_r8 ! kold kbak kstp knew
757 fwd1=0.0_r8 ! fwd2 fwd1 fwd0
758 fwd2=0.0_r8 ! bkw2 bkw1 bkw0 bkw_new
759#ifdef SOLVE3D
760 bkw_new=0.0_r8
761 bkw0=1.0_r8
762#else
763 bkw_new=1.0_r8
764 bkw0=0.0_r8
765#endif
766 bkw1=0.0_r8
767 bkw2=0.0_r8
768 ELSE IF (first_2d_step+1) THEN
769 kbak=kstp-1
770 IF (kbak.lt.1) kbak=4
771 kold=kbak
772 fwd0=1.0_r8 ! Logically AB2-AM3 forward-
773 fwd1=0.0_r8 ! backward scheme with maximum
774 fwd2=0.0_r8 ! stability coefficients while
775 bkw_new=1.0833333333333_r8 ! maintaining third-order
776 bkw0=-0.1666666666666_r8 ! accuracy, alpha_max=1.73
777 bkw1= 0.0833333333333_r8
778 bkw2= 0.0_r8
779 ELSE
780 kbak=kstp-1
781 IF (kbak.lt.1) kbak=4
782 kold=kbak-1
783 IF (kold.lt.1) kold=4
784 fwd0=1.781105_r8
785 fwd1=-1.06221_r8
786 fwd2=0.281105_r8
787 bkw_new=0.614_r8
788 bkw0=0.285_r8
789 bkw1=0.0880_r8
790 bkw2=0.013_r8
791 END IF
792
793#ifdef DEBUG
794!
795 IF (master) THEN
796 WRITE (20,10) iic(ng), iif(ng), kold, kbak, kstp, knew
797 10 FORMAT (' iic = ',i5.5,' iif = ',i3.3, &
798 & ' kold = ',i1,' kbak = ',i1,' kstp = ',i1,' knew = ',i1)
799 END IF
800#endif
801!
802!-----------------------------------------------------------------------
803! Compute BASIC STATE total depth (m) arrays and vertically
804! integerated mass fluxes.
805!-----------------------------------------------------------------------
806!
807#if defined DISTRIBUTE && !defined NESTING
808# define IR_RANGE IstrUm2-1,Iendp2
809# define JR_RANGE JstrVm2-1,Jendp2
810# define IU_RANGE IstrUm1-1,Iendp2
811# define JU_RANGE Jstrm1-1,Jendp2
812# define IV_RANGE Istrm1-1,Iendp2
813# define JV_RANGE JstrVm1-1,Jendp2
814#else
815# define IR_RANGE IstrUm2-1,Iendp2
816# define JR_RANGE JstrVm2-1,Jendp2
817# define IU_RANGE IstrUm2,Iendp2
818# define JU_RANGE JstrVm2-1,Jendp2
819# define IV_RANGE IstrUm2-1,Iendp2
820# define JV_RANGE JstrVm2,Jendp2
821#endif
822
823 DO j=jr_range
824 DO i=ir_range
825!^ Drhs(i,j)=h(i,j)+fwd0*zeta(i,j,kstp)+ &
826!^ & fwd1*zeta(i,j,kbak)+ &
827!^ & fwd2*zeta(i,j,kold)
828!^ using background instead
829 drhs(i,j)=h(i,j)+zeta(i,j,kstp)
830 END DO
831 END DO
832!
833 DO j=ju_range
834 DO i=iu_range
835 cff=0.5_r8*on_u(i,j)
836 cff1=cff*(drhs(i,j)+drhs(i-1,j))
837!^ urhs(i,j)=fwd0*ubar(i,j,kstp)+ &
838!^ & fwd1*ubar(i,j,kbak)+ &
839!^ & fwd2*ubar(i,j,kold)
840!^ using background instead
841 urhs(i,j)=ubar(i,j,kstp)
842 duon(i,j)=urhs(i,j)*cff1
843 END DO
844 END DO
845!
846 DO j=jv_range
847 DO i=iv_range
848 cff=0.5_r8*om_v(i,j)
849 cff1=cff*(drhs(i,j)+drhs(i,j-1))
850!^ vrhs(i,j)=fwd0*vbar(i,j,kstp)+ &
851!^ & fwd1*vbar(i,j,kbak)+ &
852!^ & fwd2*vbar(i,j,kold)
853!^ using background instead
854 vrhs(i,j)=vbar(i,j,kstp)
855 dvom(i,j)=vrhs(i,j)*cff1
856 END DO
857 END DO
858
859#undef IU_RANGE
860#undef IV_RANGE
861#undef JU_RANGE
862#undef JV_RANGE
863
864#if defined DISTRIBUTE && \
865 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
866!
867! In distributed-memory, the I- and J-ranges are different and a
868! special exchange is done here to avoid having three ghost points
869! for high-order numerical stencils. Notice that a private array is
870! passed below to the exchange routine. It also applies periodic
871! boundary conditions, if appropriate and no partitions in I- or
872! J-directions.
873!
874 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
875 CALL exchange_u2d_tile (ng, tile, &
876 & imins, imaxs, jmins, jmaxs, &
877 & duon)
878 CALL exchange_v2d_tile (ng, tile, &
879 & imins, imaxs, jmins, jmaxs, &
880 & dvom)
881 END IF
882 CALL mp_exchange2d (ng, tile, inlm, 2, &
883 & imins, imaxs, jmins, jmaxs, &
884 & nghostpoints, &
885 & ewperiodic(ng), nsperiodic(ng), &
886 & duon, dvom)
887#endif
888!
889! Compute integral mass flux across open boundaries and adjust
890! for volume conservation. Compute BASIC STATE value.
891! HGA: Need to resolve 'krhs' index here.
892!
893 IF (any(volcons(:,ng))) THEN
894 CALL obc_flux_tile (ng, tile, &
895 & lbi, ubi, lbj, ubj, &
896 & imins, imaxs, jmins, jmaxs, &
897 & knew, &
898#ifdef MASKING
899 & umask, vmask, &
900#endif
901 & h, om_v, on_u, &
902 & ubar, vbar, zeta)
903!
904! Set vertically integrated mass fluxes DUon and DVom along the open
905! boundaries in such a way that the integral volume is conserved.
906!
907 CALL set_duv_bc_tile (ng, tile, &
908 & lbi, ubi, lbj, ubj, &
909 & imins, imaxs, jmins, jmaxs, &
910 & krhs, &
911#ifdef MASKING
912 & umask, vmask, &
913#endif
914 & om_v, on_u, &
915 & ubar, vbar, &
916 & drhs, duon, dvom)
917 END IF
918!
919!-----------------------------------------------------------------------
920! Compute BASIC STATE fields associated with pressure gradient and
921! time-stepping of adjoint free-surface, "zeta_new".
922!-----------------------------------------------------------------------
923!
924! Notice that the new local free-surface is allocated so it can be
925! passed as an argumment to "zetabc_local". An automatic array cannot
926! be used here because of weird memory problems.
927!
928 allocate ( ad_zeta_new(imins:imaxs,jmins:jmaxs) )
929 ad_zeta_new = 0.0_r8
930!
931! Compute "zeta_new" at new time step and interpolate it half-step
932! backward, "zwrk" for the subsequent computation of the adjoint
933! barotropic pressure gradient. Here, we use the BASIC STATE values.
934! Thus, the nonlinear correction to the pressure-gradient term from
935! "kstp" to "knew" is not needed for Forward-Euler to Forward-Backward
936! steps (PGF_FB_CORRECTION method).
937!
938! Get background zeta_new from BASIC state. Notice the I- and J-range
939! used to avoid calling nonlinear 'zetabc_local' routine.
940!
941 DO j=jr_range
942 DO i=ir_range
943 zeta_new(i,j)=zeta(i,j,knew)
944#ifdef MASKING
945 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
946# ifdef WET_DRY_NOT_YET
947!^ zeta_new(i,j)=zeta_new(i,j)+ &
948!^ & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
949# endif
950#endif
951 dnew(i,j)=h(i,j)+zeta_new(i,j)
952 dnew_rd(i,j)=dnew(i,j)
953 dstp(i,j)=h(i,j)+zeta(i,j,kstp)
954 END DO
955 END DO
956
957#undef IR_RANGE
958#undef JR_RANGE
959!
960 DO j=jstrv-1,jend
961 DO i=istru-1,iend
962!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
963!^ & dtfast(ng)*pm(i,j)*pn(i,j)* &
964!^ & (DUon(i,j)-DUon(i+1,j)+ &
965!^ & DVom(i,j)-DVom(i,j+1))
966#ifdef MASKING
967!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
968# ifdef WET_DRY_NOT_YET
969!! zeta_new(i,j)=zeta_new(i,j)+ &
970!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
971# endif
972#endif
973!^
974! using background instead
975 zwrk(i,j)=bkw_new*zeta_new(i,j)+ &
976 & bkw0*zeta(i,j,kstp)+ &
977 & bkw1*zeta(i,j,kbak)+ &
978 & bkw2*zeta(i,j,kold)
979#if defined VAR_RHO_2D && defined SOLVE3D
980 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
981 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
982 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
983#else
984 rzeta(i,j)=zwrk(i,j)
985 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
986#endif
987 END DO
988 END DO
989!
990!-----------------------------------------------------------------------
991! Save adjoint 2D solution at knew index for IO purposes.
992!-----------------------------------------------------------------------
993!
994#ifdef SOLVE3D
995 IF (iif(ng).eq.nfast(ng)) THEN
996 DO j=jstrr,jendr
997 DO i=istrr,iendr
998 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
999 END DO
1000 DO i=istr,iendr
1001 ad_ubar_sol(i,j)=ad_ubar(i,j,knew)
1002 END DO
1003 IF (j.ge.jstr) THEN
1004 DO i=istrr,iendr
1005 ad_vbar_sol(i,j)=ad_vbar(i,j,knew)
1006 END DO
1007 END IF
1008 END DO
1009 END IF
1010#else
1011 DO j=jstrr,jendr
1012 DO i=istrr,iendr
1013 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
1014 END DO
1015 DO i=istr,iendr
1016 ad_ubar_sol(i,j)=ad_ubar(i,j,knew)
1017 END DO
1018 IF (j.ge.jstr) THEN
1019 DO i=istrr,iendr
1020 ad_vbar_sol(i,j)=ad_vbar(i,j,knew)
1021 END DO
1022 END IF
1023 END DO
1024#endif
1025!
1026!-----------------------------------------------------------------------
1027! Adjoint of exchange halo tile information.
1028!-----------------------------------------------------------------------
1029!
1030#ifdef DISTRIBUTE
1031!^ CALL mp_exchange2d (ng, tile, iTLM, 3, &
1032!^ & LBi, UBi, LBj, UBj, &
1033!^ & NghostPoints, &
1034!^ & EWperiodic(ng), NSperiodic(ng), &
1035!^ & tl_zeta(:,:,knew), &
1036!^ & tl_ubar(:,:,knew), &
1037!^ & tl_vbar(:,:,knew))
1038!^
1039 CALL ad_mp_exchange2d (ng, tile, iadm, 3, &
1040 & lbi, ubi, lbj, ubj, &
1041 & nghostpoints, &
1042 & ewperiodic(ng), nsperiodic(ng), &
1043 & ad_zeta(:,:,knew), &
1044 & ad_ubar(:,:,knew), &
1045 & ad_vbar(:,:,knew))
1046#endif
1047
1048 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1049!^ CALL exchange_v2d_tile (ng, tile, &
1050!^ & LBi, UBi, LBj, UBj, &
1051!^ & tl_vbar(:,:,knew))
1052!^
1053 CALL ad_exchange_v2d_tile (ng, tile, &
1054 & lbi, ubi, lbj, ubj, &
1055 & ad_vbar(:,:,knew))
1056!^ CALL exchange_u2d_tile (ng, tile, &
1057!^ & LBi, UBi, LBj, UBj, &
1058!^ & tl_ubar(:,:,knew))
1059!^
1060 CALL ad_exchange_u2d_tile (ng, tile, &
1061 & lbi, ubi, lbj, ubj, &
1062 & ad_ubar(:,:,knew))
1063!^ CALL exchange_r2d_tile (ng, tile, &
1064!^ & LBi, UBi, LBj, UBj, &
1065!^ & tl_zeta(:,:,knew))
1066!^
1067 CALL ad_exchange_r2d_tile (ng, tile, &
1068 & lbi, ubi, lbj, ubj, &
1069 & ad_zeta(:,:,knew))
1070 END IF
1071
1072#ifdef NESTING
1073# ifdef SOLVE3D
1074!
1075!-----------------------------------------------------------------------
1076! If nesting and after all fast time steps are completed, adjoint of
1077! exchange halo information to time averaged fields.
1078!-----------------------------------------------------------------------
1079!
1080 IF (iif(ng).eq.nfast(ng)) THEN
1081!
1082! In nesting applications with refinement grids, we need to exchange
1083! the DU_avg2 and DV_avg2 fluxes boundary information for the case
1084! that a contact point is at a tile partition. Notice that in such
1085! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
1086!
1087# ifdef DISTRIBUTE
1088!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
1089!^ & LBi, UBi, LBj, UBj, &
1090!^ & NghostPoints, &
1091!^ & EWperiodic(ng), NSperiodic(ng), &
1092!^ & tl_DU_avg2, tl_DV_avg2)
1093!^
1094 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
1095 & lbi, ubi, lbj, ubj, &
1096 & nghostpoints, &
1097 & ewperiodic(ng), nsperiodic(ng), &
1098 & ad_du_avg2, ad_dv_avg2)
1099!^ CALL mp_exchange2d (ng, tile, iTLM, 3, &
1100!^ & LBi, UBi, LBj, UBj, &
1101!^ & NghostPoints, &
1102!^ & EWperiodic(ng), NSperiodic(ng), &
1103!^ & tl_Zt_avg1, tl_DU_avg1, tl_DV_avg1)
1104!^
1105 CALL ad_mp_exchange2d (ng, tile, iadm, 3, &
1106 & lbi, ubi, lbj, ubj, &
1107 & nghostpoints, &
1108 & ewperiodic(ng), nsperiodic(ng), &
1109 & ad_zt_avg1, ad_du_avg1, ad_dv_avg1)
1110!
1111# endif
1112 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1113!^ CALL exchange_v2d_tile (ng, tile, &
1114!^ & LBi, UBi, LBj, UBj, &
1115!^ & tl_DV_avg2)
1116!^
1117 CALL ad_exchange_v2d_tile (ng, tile, &
1118 & lbi, ubi, lbj, ubj, &
1119 & ad_dv_avg2)
1120!^ CALL exchange_u2d_tile (ng, tile, &
1121!^ & LBi, UBi, LBj, UBj, &
1122!^ & tl_DU_avg2)
1123!^
1124 CALL ad_exchange_u2d_tile (ng, tile, &
1125 & lbi, ubi, lbj, ubj, &
1126 & ad_du_avg2)
1127!^ CALL exchange_v2d_tile (ng, tile, &
1128!^ & LBi, UBi, LBj, UBj, &
1129!^ & tl_DV_avg1)
1130!^
1131 CALL ad_exchange_v2d_tile (ng, tile, &
1132 & lbi, ubi, lbj, ubj, &
1133 & ad_dv_avg1)
1134!^ CALL exchange_u2d_tile (ng, tile, &
1135!^ & LBi, UBi, LBj, UBj, &
1136!^ & tl_DU_avg1)
1137!^
1138 CALL ad_exchange_u2d_tile (ng, tile, &
1139 & lbi, ubi, lbj, ubj, &
1140 & ad_du_avg1)
1141!^ CALL exchange_r2d_tile (ng, tile, &
1142!^ & LBi, UBi, LBj, UBj, &
1143!^ & tl_Zt_avg1)
1144!^
1145 CALL ad_exchange_r2d_tile (ng, tile, &
1146 & lbi, ubi, lbj, ubj, &
1147 & ad_zt_avg1)
1148 END IF
1149
1150 END IF
1151# else
1152!
1153! In nesting applications with refinement grids, we need to exchange
1154! the DU_flux and DV_flux fluxes boundary information for the case
1155! that a contact point is at a tile partition. Notice that in such
1156! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
1157!
1158# ifdef DISTRIBUTE
1159!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
1160!^ & LBi, UBi, LBj, UBj, &
1161!^ & NghostPoints, &
1162!^ & EWperiodic(ng), NSperiodic(ng), &
1163!^ & tl_DU_flux, tl_DV_flux)
1164!^
1165 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
1166 & lbi, ubi, lbj, ubj, &
1167 & nghostpoints, &
1168 & ewperiodic(ng), nsperiodic(ng), &
1169 & ad_du_flux, ad_dv_flux)
1170!
1171# endif
1172 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1173!^ CALL exchange_v2d_tile (ng, tile, &
1174!^ & LBi, UBi, LBj, UBj, &
1175!^ & tl_DV_flux)
1176!^
1177 CALL ad_exchange_v2d_tile (ng, tile, &
1178 & lbi, ubi, lbj, ubj, &
1179 & ad_dv_flux)
1180!^ CALL exchange_u2d_tile (ng, tile, &
1181!^ & LBi, UBi, LBj, UBj, &
1182!^ & tl_DU_flux)
1183!^
1184 CALL ad_exchange_u2d_tile (ng, tile, &
1185 & lbi, ubi, lbj, ubj, &
1186 & ad_du_flux)
1187 END IF
1188# endif
1189#endif
1190
1191#ifdef SOLVE3D
1192!
1193!-----------------------------------------------------------------------
1194! Adjoint replace the new free-surface zeta(:,:,knew) with it fast
1195! time-averaged value, Zt_avg1 at the of the last 2D time step. Recall
1196! this is state variable is the one that communicates with the 3D
1197! kernel.
1198!-----------------------------------------------------------------------
1199!
1200 IF (iif(ng).eq.nfast(ng)) THEN
1201!^ CALL tl_set_depth (ng, tile, iTLM)
1202!^
1203 CALL ad_set_depth (ng, tile, iadm)
1204!
1205 DO j=jstrr,jendr
1206 DO i=istrr,iendr
1207!^ tl_zeta(i,j,knew)=tl_Zt_avg1(i,j)
1208!^
1209 ad_zt_avg1(i,j)=ad_zt_avg1(i,j)+ad_zeta(i,j,knew)
1210 ad_zeta(i,j,knew)=0.0_r8
1211 END DO
1212 END DO
1213 END IF
1214#endif
1215
1216#ifdef WET_DRY_NOT_YET
1217!
1218!-----------------------------------------------------------------------
1219! Adjoint of compute new wet/dry masks.
1220!-----------------------------------------------------------------------
1221!
1222!^ CALL wetdry_tile (ng, tile, &
1223!^ & LBi, UBi, LBj, UBj, &
1224!^ & IminS, ImaxS, JminS, JmaxS, &
1225# ifdef MASKING
1226!^ & pmask, rmask, umask, vmask, &
1227# endif
1228!^ & h, zeta(:,:,knew), &
1229# ifdef SOLVE3D
1230!^ & DU_avg1, DV_avg1, &
1231!^ & rmask_wet_avg, &
1232# endif
1233!^ & pmask_wet, pmask_full, &
1234!^ & rmask_wet, rmask_full, &
1235!^ & umask_wet, umask_full, &
1236!^ & vmask_wet, vmask_full)
1237!^
1238!^ HGA: Need the ADM code here.
1239!^
1240#endif
1241!
1242!-----------------------------------------------------------------------
1243! Apply adjoint momentum transport point sources (like river runoff),
1244! if any.
1245!
1246! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
1247! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
1248!-----------------------------------------------------------------------
1249!
1250 IF (luvsrc(ng)) THEN
1251 DO is=1,nsrc(ng)
1252 i=sources(ng)%Isrc(is)
1253 j=sources(ng)%Jsrc(is)
1254 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1255 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1256 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
1257#if defined NESTING && !defined SOLVE3D
1258!^ tl_DU_flux(i,j)=SOURCES(ng)%tl_Qbar(is)
1259!^
1260 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1261 & ad_du_flux(i,j)
1262 ad_du_flux(i,j)=0.0_r8
1263#endif
1264#ifdef SOLVE3D
1265!^ tl_DU_avg1(i,j)=SOURCES(ng)%tl_Qbar(is)
1266!^
1267 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1268 & ad_du_avg1(i,j)
1269 ad_du_avg1(i,j)=0.0_r8
1270#endif
1271 cff=1.0_r8/(on_u(i,j)* &
1272 & 0.5_r8*(dnew(i-1,j)+dnew(i,j)))
1273!^ tl_ubar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
1274!^ & SOURCES(ng)%Qbar(is)*tl_cff
1275!^
1276 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1277 & cff*ad_ubar(i,j,knew)
1278 ad_cff=ad_cff+ &
1279 & sources(ng)%Qbar(is)*ad_ubar(i,j,knew)
1280
1281 ad_ubar(i,j,knew)=0.0_r8
1282!^ tl_cff=-cff*cff*on_u(i,j)* &
1283!^ & 0.5_r8*(tl_Dnew(i-1,j)+tl_Dnew(i,j))
1284!^
1285 adfac=-cff*cff*on_u(i,j)*0.5_r8*ad_cff
1286 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac
1287 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac
1288 ad_cff=0.0_r8
1289 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
1290#if defined NESTING && !defined SOLVE3D
1291!^ tl_DV_flux(i,j)=SOURCES(ng)%tl_Qbar(is)
1292!^
1293 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1294 & ad_dv_flux(i,j)
1295 ad_dv_flux(i,j)=0.0_r8
1296#endif
1297#ifdef SOLVE3D
1298!^ tl_DV_avg1(i,j)=SOURCES(ng)%tl_Qbar(is)
1299!^
1300 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1301 & ad_dv_avg1(i,j)
1302 ad_dv_avg1(i,j)=0.0_r8
1303#endif
1304 cff=1.0_r8/(om_v(i,j)* &
1305 & 0.5_r8*(dnew(i,j-1)+dnew(i,j)))
1306!^ tl_vbar(i,j,knew)=SOURCES(ng)%tl_Qbar(is)*cff+ &
1307!^ & SOURCES(ng)%Qbar(is)*tl_cff
1308!^
1309 sources(ng)%ad_Qbar(is)=sources(ng)%ad_Qbar(is)+ &
1310 & cff*ad_vbar(i,j,knew)
1311 ad_cff=ad_cff+ &
1312 & sources(ng)%Qbar(is)*ad_vbar(i,j,knew)
1313 ad_vbar(i,j,knew)=0.0_r8
1314!^ tl_cff=-cff*cff*om_v(i,j)* &
1315!^ & 0.5_r8*(tl_Dnew(i,j-1)+tl_Dnew(i,j))
1316!^
1317 adfac=-cff*cff*om_v(i,j)*0.5_r8*ad_cff
1318 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac
1319 ad_dnew(i,j )=ad_dnew(i,j )+adfac
1320 ad_cff=0.0_r8
1321 END IF
1322 END IF
1323 END DO
1324 END IF
1325
1326#if defined SOLVE3D || (defined NESTING && !defined SOLVE3D)
1327!
1328! Set adjoint barotropic fluxes along physical boundaries.
1329!
1330# ifdef SOLVE3D
1331 cff1=0.5*weight(1,iif(ng),ng)
1332!
1333# endif
1334 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1335 IF (domain(ng)%Northern_Edge(tile)) THEN
1336 DO i=istrr,iendr
1337# if defined NESTING && !defined SOLVE3D
1338!^ tl_DV_flux(i,Jend+1)=0.5_r8*om_v(i,Jend+1)* &
1339!^ & ((Dnew(i,Jend+1)+ &
1340!^ & Dnew(i,Jend ))* &
1341!^ & tl_vbar(i,Jend+1,knew)+ &
1342!^ & (tl_Dnew(i,Jend+1)+ &
1343!^ & tl_Dnew(i,Jend ))* &
1344!^ & vbar(i,Jend+1,knew))
1345!^
1346 adfac=0.5_r8*om_v(i,jend+1)*ad_dv_flux(i,jend+1)
1347 adfac1=adfac1*vbar(i,jend+1,knew)
1348 ad_vbar(i,jend+1,knew)=ad_vbar(i,jend+1,knew)+ &
1349 & (dnew(i,jend+1)+ &
1350 & dnew(i,jend ))*adfac
1351 ad_dnew(i,jend )=ad_dnew(i,jend )+adfac1
1352 ad_dnew(i,jend+1)=ad_dnew(i,jend+1)+adfac1
1353 ad_dv_flux(i,jend+1)=0.0_r8
1354# else
1355!^ tl_DV_avg1(i,Jend+1)=tl_DV_avg1(i,Jend+1)+ &
1356!^ & cff1*om_v(i,Jend+1)* &
1357!^ & ((Dnew(i,Jend+1)+ &
1358!^ & Dnew(i,Jend ))* &
1359!^ & tl_vbar(i,Jend+1,knew)+ &
1360!^ & (tl_Dnew(i,Jend+1)+ &
1361!^ & tl_Dnew(i,Jend ))* &
1362!^ & vbar(i,Jend+1,knew))
1363!^
1364 adfac=cff1*om_v(i,jend+1)*ad_dv_avg1(i,jend+1)
1365 adfac1=adfac*vbar(i,jend+1,knew)
1366 ad_vbar(i,jend+1,knew)=ad_vbar(i,jend+1,knew)+ &
1367 & (dnew(i,jend+1)+ &
1368 & dnew(i,jend ))*adfac
1369 ad_dnew(i,jend )=ad_dnew(i,jend )+adfac1
1370 ad_dnew(i,jend+1)=ad_dnew(i,jend+1)+adfac1
1371# endif
1372 END DO
1373 DO i=istru,iend
1374# if defined NESTING && !defined SOLVE3D
1375!^ tl_DU_flux(i,Jend+1)=0.5_r8*on_u(i,Jend+1)* &
1376!^ & ((Dnew(i ,Jend+1)+ &
1377!^ & Dnew(i-1,Jend+1))* &
1378!^ & tl_ubar(i,Jend+1,knew)+ &
1379!^ & (tl_Dnew(i ,Jend+1)+ &
1380!^ & tl_Dnew(i-1,Jend+1))* &
1381!^ & ubar(i,Jend+1,knew))
1382!^
1383 adfac=0.5_r8*on_u(i,jend+1)*ad_du_flux(i,jend+1)
1384 adfac1=adfac*ubar(i,jend+1,knew)
1385 ad_ubar(i,jend+1,knew)=ad_ubar(i,jend+1,knew)+ &
1386 & (dnew(i ,jend+1)+ &
1387 & dnew(i-1,jend+1))*adfac
1388 ad_dnew(i-1,jend+1)=ad_dnew(i-1,jend+1)+adfac1
1389 ad_dnew(i ,jend+1)=ad_dnew(i ,jend+1)+adfac1
1390 ad_du_flux(i,jend+1)=0.0_r8
1391# else
1392!^ tl_DU_avg1(i,Jend+1)=tl_DU_avg1(i,Jend+1)+ &
1393!^ & cff1*on_u(i,Jend+1)* &
1394!^ & ((Dnew(i ,Jend+1)+ &
1395!^ & Dnew(i-1,Jend+1))* &
1396!^ & tl_ubar(i,Jend+1,knew)+ &
1397!^ & (tl_Dnew(i ,Jend+1)+ &
1398!^ & tl_Dnew(i-1,Jend+1))* &
1399!^ & ubar(i,Jend+1,knew))
1400!^
1401 adfac=cff1*on_u(i,jend+1)*ad_du_avg1(i,jend+1)
1402 adfac1=adfac*ubar(i,jend+1,knew)
1403 ad_ubar(i,jend+1,knew)=ad_ubar(i,jend+1,knew)+ &
1404 & (dnew(i ,jend+1)+ &
1405 & dnew(i-1,jend+1))*adfac
1406 ad_dnew(i-1,jend+1)=ad_dnew(i-1,jend+1)+adfac1
1407 ad_dnew(i ,jend+1)=ad_dnew(i ,jend+1)+adfac1
1408# endif
1409 END DO
1410 END IF
1411 END IF
1412
1413 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1414 IF (domain(ng)%Southern_Edge(tile)) THEN
1415 DO i=istrr,iendr
1416# if defined NESTING && !defined SOLVE3D
1417!^ tl_DV_flux(i,JstrV-1)=0.5_r8*om_v(i,JstrV-1)* &
1418!^ & ((Dnew(i,JstrV-1)+ &
1419!^ & Dnew(i,JstrV-2))* &
1420!^ & tl_vbar(i,JstrV-1,knew)+ &
1421!^ & (tl_Dnew(i,JstrV-1)+ &
1422!^ & tl_Dnew(i,JstrV-2))* &
1423!^ & vbar(i,JstrV-1,knew))
1424!^
1425 adfac=0.5_r8*om_v(i,jstrv-1)*ad_dv_flux(i,jstrv-1)
1426 adfac1=adfac*vbar(i,jstrv-1,knew)
1427 ad_vbar(i,jstrv-1,knew)=ad_vbar(i,jstrv-1,knew)+ &
1428 & (dnew(i,jstrv-1)+ &
1429 & dnew(i,jstrv-2))*adfac
1430 ad_dnew(i,jstrv-2)=ad_dnew(i,jstrv-2)+adfac1
1431 ad_dnew(i,jstrv-1)=ad_dnew(i,jstrv-1)+adfac1
1432 ad_dv_flux(i,jstrv-1)=0.0_r8
1433# else
1434!^ tl_DV_avg1(i,JstrV-1)=tl_DV_avg1(i,JstrV-1)+ &
1435!^ & cff1*om_v(i,JstrV-1)* &
1436!^ & ((Dnew(i,JstrV-1)+ &
1437!^ & Dnew(i,JstrV-2))* &
1438!^ & tl_vbar(i,JstrV-1,knew)+ &
1439!^ & (tl_Dnew(i,JstrV-1)+ &
1440!^ & tl_Dnew(i,JstrV-2))* &
1441!^ & vbar(i,JstrV-1,knew))
1442!^
1443 adfac=cff1*om_v(i,jstrv-1)*ad_dv_avg1(i,jstrv-1)
1444 adfac1=adfac*vbar(i,jstrv-1,knew)
1445 ad_vbar(i,jstrv-1,knew)=ad_vbar(i,jstrv-1,knew)+ &
1446 & (dnew(i,jstrv-1)+ &
1447 & dnew(i,jstrv-2))*adfac
1448 ad_dnew(i,jstrv-2)=ad_dnew(i,jstrv-2)+adfac1
1449 ad_dnew(i,jstrv-1)=ad_dnew(i,jstrv-1)+adfac1
1450# endif
1451 END DO
1452 DO i=istru,iend
1453# if defined NESTING && !defined SOLVE3D
1454!^ tl_DU_flux(i,Jstr-1)=0.5_r8*on_u(i,Jstr-1)* &
1455!^ & ((Dnew(i ,Jstr-1)+ &
1456!^ & Dnew(i-1,Jstr-1))* &
1457!^ & tl_ubar(i,Jstr-1,knew)+ &
1458!^ & (tl_Dnew(i ,Jstr-1)+ &
1459!^ & tl_Dnew(i-1,Jstr-1))* &
1460!^ & ubar(i,Jstr-1,knew))
1461!^
1462 adfac=0.5_r8*on_u(i,jstr-1)*ad_du_flux(i,jstr-1)
1463 adfac1=adfac*ubar(i,jstr-1,knew)
1464 ad_ubar(i,jstr-1,knew)=ad_ubar(i,jstr-1,knew)+ &
1465 & (dnew(i ,jstr-1)+ &
1466 & dnew(i-1,jstr-1))*adfac
1467 ad_dnew(i-1,jstr-1)=ad_dnew(i-1,jstr-1)+adfac1
1468 ad_dnew(i ,jstr-1)=ad_dnew(i ,jstr-1)+adfac1
1469 ad_du_flux(i,jstr-1)=0.0_r8
1470# else
1471!^ tl_DU_avg1(i,Jstr-1)=tl_DU_avg1(i,Jstr-1)+ &
1472!^ & cff1*on_u(i,Jstr-1)* &
1473!^ & ((Dnew(i ,Jstr-1)+ &
1474!^ & Dnew(i-1,Jstr-1))* &
1475!^ & tl_ubar(i,Jstr-1,knew)+ &
1476!^ & (tl_Dnew(i ,Jstr-1)+ &
1477!^ & tl_Dnew(i-1,Jstr-1))* &
1478!^ & ubar(i,Jstr-1,knew))
1479!^
1480# endif
1481 adfac=cff1*on_u(i,jstr-1)*ad_du_avg1(i,jstr-1)
1482 adfac1=adfac*ubar(i,jstr-1,knew)
1483 ad_ubar(i,jstr-1,knew)=ad_ubar(i,jstr-1,knew)+ &
1484 & (dnew(i ,jstr-1)+ &
1485 & dnew(i-1,jstr-1))*adfac
1486 ad_dnew(i-1,jstr-1)=ad_dnew(i-1,jstr-1)+adfac1
1487 ad_dnew(i ,jstr-1)=ad_dnew(i ,jstr-1)+adfac1
1488 END DO
1489 END IF
1490 END IF
1491
1492 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1493 IF (domain(ng)%Eastern_Edge(tile)) THEN
1494 DO j=jstrv,jend
1495# if defined NESTING && !defined SOLVE3D
1496!^ tl_DV_flux(Iend+1,j)=0.5_r8*om_v(Iend+1,j)* &
1497!^ & ((Dnew(Iend+1,j )+ &
1498!^ & Dnew(Iend+1,j-1))* &
1499!^ & tl_vbar(Iend+1,j,knew)+ &
1500!^ & (tl_Dnew(Iend+1,j )+ &
1501!^ & tl_Dnew(Iend+1,j-1))* &
1502!^ & vbar(Iend+1,j,knew))
1503!^
1504 adfac=0.5_r8*om_v(iend+1,j)*ad_dv_flux(iend+1,j)
1505 adfac1=adfac*vbar(iend+1,j,knew)
1506 ad_vbar(iend+1,j,knew)=ad_vbar(iend+1,j,knew)+ &
1507 & (dnew(iend+1,j )+ &
1508 & dnew(iend+1,j-1))*adfac
1509 ad_dnew(iend+1,j-1)=ad_dnew(iend+1,j-1)+adfac1
1510 ad_dnew(iend+1,j )=ad_dnew(iend+1,j )+adfac1
1511 ad_dv_flux(iend+1,j)=0.0_r8
1512# else
1513!^ tl_DV_avg1(Iend+1,j)=tl_DV_avg1(Iend+1,j)+ &
1514!^ & cff1*om_v(Iend+1,j)* &
1515!^ & ((Dnew(Iend+1,j )+ &
1516!^ & Dnew(Iend+1,j-1))* &
1517!^ & tl_vbar(Iend+1,j,knew)+ &
1518!^ & (tl_Dnew(Iend+1,j )+ &
1519!^ & tl_Dnew(Iend+1,j-1))* &
1520!^ & vbar(Iend+1,j,knew))
1521!^
1522 adfac=cff1*om_v(iend+1,j)*ad_dv_avg1(iend+1,j)
1523 adfac1=adfac*vbar(iend+1,j,knew)
1524 ad_vbar(iend+1,j,knew)=ad_vbar(iend+1,j,knew)+ &
1525 & (dnew(iend+1,j )+ &
1526 & dnew(iend+1,j-1))*adfac
1527 ad_dnew(iend+1,j-1)=ad_dnew(iend+1,j-1)+adfac1
1528 ad_dnew(iend+1,j )=ad_dnew(iend+1,j )+adfac1
1529# endif
1530 END DO
1531 DO j=jstrr,jendr
1532# if defined NESTING && !defined SOLVE3D
1533!^ tl_DU_flux(Iend+1,j)=0.5_r8*on_u(Iend+1,j)* &
1534!^ & ((Dnew(Iend+1,j)+ &
1535!^ & Dnew(Iend ,j))* &
1536!^ & tl_ubar(Iend+1,j,knew)+ &
1537!^ & (tl_Dnew(Iend+1,j)+ &
1538!^ & tl_Dnew(Iend ,j))* &
1539!^ & ubar(Iend+1,j,knew))
1540!^
1541 adfac=0.5_r8*on_u(iend+1,j)*ad_du_flux(iend+1,j)
1542 adfac1=adfac*ubar(iend+1,j,knew)
1543 ad_ubar(iend+1,j,knew)=ad_ubar(iend+1,j,knew)+ &
1544 & (dnew(iend+1,j)+ &
1545 & dnew(iend ,j))*adfac
1546 ad_dnew(iend ,j)=ad_dnew(iend ,j)+adfac1
1547 ad_dnew(iend+1,j)=ad_dnew(iend+1,j)+adfac1
1548 ad_du_flux(iend+1,j)=0.0_r8
1549# else
1550!^ tl_DU_avg1(Iend+1,j)=tl_DU_avg1(Iend+1,j)+ &
1551!^ & cff1*on_u(Iend+1,j)* &
1552!^ & ((Dnew(Iend+1,j)+ &
1553!^ & Dnew(Iend ,j))* &
1554!^ & tl_ubar(Iend+1,j,knew)+ &
1555!^ & (tl_Dnew(Iend+1,j)+ &
1556!^ & tl_Dnew(Iend ,j))* &
1557!^ & ubar(Iend+1,j,knew))
1558!^
1559 adfac=cff1*on_u(iend+1,j)*ad_du_avg1(iend+1,j)
1560 adfac1=adfac*ubar(iend+1,j,knew)
1561 ad_ubar(iend+1,j,knew)=ad_ubar(iend+1,j,knew)+ &
1562 & (dnew(iend+1,j)+ &
1563 & dnew(iend ,j))*adfac
1564 ad_dnew(iend ,j)=ad_dnew(iend ,j)+adfac1
1565 ad_dnew(iend+1,j)=ad_dnew(iend+1,j)+adfac1
1566# endif
1567 END DO
1568 END IF
1569 END IF
1570
1571 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1572 IF (domain(ng)%Western_Edge(tile)) THEN
1573 DO j=jstrv,jend
1574# if defined NESTING && !defined SOLVE3D
1575!^ tl_DV_flux(Istr-1,j)=0.5_r8*om_v(Istr-1,j)* &
1576!^ & ((Dnew(Istr-1,j )+ &
1577!^ & Dnew(Istr-1,j-1))* &
1578!^ & tl_vbar(Istr-1,j,knew)+ &
1579!^ & (tl_Dnew(Istr-1,j )+ &
1580!^ & tl_Dnew(Istr-1,j-1))* &
1581!^ & vbar(Istr-1,j,knew))
1582!^
1583 adfac=0.5_r8*om_v(istr-1,j)*ad_dv_flux(istr-1,j)
1584 adfac1=adfac*vbar(istr-1,j,knew)
1585 ad_vbar(istr-1,j,knew)=ad_vbar(istr-1,j,knew)+ &
1586 & (dnew(istr-1,j )+ &
1587 & dnew(istr-1,j-1))*adfac
1588 ad_dnew(istr-1,j-1)=ad_dnew(istr-1,j-1)+adfac1
1589 ad_dnew(istr-1,j )=ad_dnew(istr-1,j )+adfac1
1590 ad_dv_flux(istr-1,j)=0.0_r8
1591# else
1592!^ tl_DV_avg1(Istr-1,j)=tl_DV_avg1(Istr-1,j)+ &
1593!^ & cff1*om_v(Istr-1,j)* &
1594!^ & ((Dnew(Istr-1,j )+ &
1595!^ & Dnew(Istr-1,j-1))* &
1596!^ & tl_vbar(Istr-1,j,knew)+ &
1597!^ & (tl_Dnew(Istr-1,j )+ &
1598!^ & tl_Dnew(Istr-1,j-1))* &
1599!^ & vbar(Istr-1,j,knew))
1600!^
1601 adfac=cff1*om_v(istr-1,j)*ad_dv_avg1(istr-1,j)
1602 adfac1=adfac*vbar(istr-1,j,knew)
1603 ad_vbar(istr-1,j,knew)=ad_vbar(istr-1,j,knew)+ &
1604 & (dnew(istr-1,j )+ &
1605 & dnew(istr-1,j-1))*adfac
1606 ad_dnew(istr-1,j-1)=ad_dnew(istr-1,j-1)+adfac1
1607 ad_dnew(istr-1,j )=ad_dnew(istr-1,j )+adfac1
1608# endif
1609 END DO
1610 DO j=jstrr,jendr
1611# if defined NESTING && !defined SOLVE3D
1612!^ tl_DU_flux(IstrU-1,j)=0.5_r8*on_u(IstrU-1,j)* &
1613!^ & ((Dnew(IstrU-1,j)+ &
1614!^ & Dnew(IstrU-2,j))* &
1615!^ & tl_ubar(IstrU-1,j,knew)+ &
1616!^ & (tl_Dnew(IstrU-1,j)+ &
1617!^ & tl_Dnew(IstrU-2,j))* &
1618!^ & ubar(IstrU-1,j,knew))
1619!^
1620 adfac=0.5_r8*on_u(istru-1,j)*ad_du_flux(istru-1,j)
1621 adfac1=adfac*ubar(istru-1,j,knew)
1622 ad_ubar(istru-1,j,knew)=ad_ubar(istru-1,j,knew)+ &
1623 & (dnew(istru-1,j)+ &
1624 & dnew(istru-2,j))*adfac
1625 ad_dnew(istru-2,j)=ad_dnew(istru-2,j)+adfac1
1626 ad_dnew(istru-1,j)=ad_dnew(istru-1,j)+adfac1
1627 ad_du_flux(istru-1,j)=0.0_r8
1628# else
1629!^ tl_DU_avg1(IstrU-1,j)=tl_DU_avg1(IstrU-1,j)+ &
1630!^ & cff1*on_u(IstrU-1,j)* &
1631!^ & ((Dnew(IstrU-1,j)+ &
1632!^ & Dnew(IstrU-2,j))* &
1633!^ & tl_ubar(IstrU-1,j,knew)+ &
1634!^ & (tl_Dnew(IstrU-1,j)+ &
1635!^ & tl_Dnew(IstrU-2,j))* &
1636!^ & ubar(IstrU-1,j,knew))
1637!^
1638 adfac=cff1*on_u(istru-1,j)*ad_du_avg1(istru-1,j)
1639 adfac1=adfac*ubar(istru-1,j,knew)
1640 ad_ubar(istru-1,j,knew)=ad_ubar(istru-1,j,knew)+ &
1641 & (dnew(istru-1,j)+ &
1642 & dnew(istru-2,j))*adfac
1643 ad_dnew(istru-2,j)=ad_dnew(istru-2,j)+adfac1
1644 ad_dnew(istru-1,j)=ad_dnew(istru-1,j)+adfac1
1645# endif
1646 END DO
1647 END IF
1648 END IF
1649!
1650 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1651 IF (domain(ng)%Northern_Edge(tile)) THEN
1652 DO i=istr-1,iendr
1653!^ tl_Dnew(i,Jend+1)=tl_h(i,Jend+1)+tl_zeta_new(i,Jend+1)
1654!^
1655 ad_h(i,jend+1)=ad_h(i,jend+1)+ &
1656 & ad_dnew(i,jend+1)
1657 ad_zeta_new(i,jend+1)=ad_zeta_new(i,jend+1)+ &
1658 & ad_dnew(i,jend+1)
1659 ad_dnew(i,jend+1)=0.0_r8
1660 END DO
1661 END IF
1662 END IF
1663 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1664 IF (domain(ng)%Southern_Edge(tile)) THEN
1665 DO i=istr-1,iendr
1666!^ tl_Dnew(i,Jstr-1)=tl_h(i,Jstr-1)+tl_zeta_new(i,Jstr-1)
1667!^
1668 ad_h(i,jstr-1)=ad_h(i,jstr-1)+ &
1669 & ad_dnew(i,jstr-1)
1670 ad_zeta_new(i,jstr-1)=ad_zeta_new(i,jstr-1)+ &
1671 & ad_dnew(i,jstr-1)
1672 ad_dnew(i,jstr-1)=0.0_r8
1673 END DO
1674 END IF
1675 END IF
1676 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1677 IF (domain(ng)%Eastern_Edge(tile)) THEN
1678 DO j=jstr-1,jendr
1679!^ tl_Dnew(Iend+1,j)=tl_h(Iend+1,j)+tl_zeta_new(Iend+1,j)
1680!^
1681 ad_h(iend+1,j)=ad_h(iend+1,j)+ &
1682 & ad_dnew(iend+1,j)
1683 ad_zeta_new(iend+1,j)=ad_zeta_new(iend+1,j)+ &
1684 & ad_dnew(iend+1,j)
1685 ad_dnew(iend+1,j)=0.0_r8
1686 END DO
1687 END IF
1688 END IF
1689 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1690 IF (domain(ng)%Western_Edge(tile)) THEN
1691 DO j=jstr-1,jendr
1692!^ tl_Dnew(Istr-1,j)=tl_h(Istr-1,j)+tl_zeta_new(Istr-1,j)
1693!^
1694 ad_h(istr-1,j)=ad_h(istr-1,j)+ &
1695 & ad_dnew(istr-1,j)
1696 ad_zeta_new(istr-1,j)=ad_zeta_new(istr-1,j)+ &
1697 & ad_dnew(istr-1,j)
1698 ad_dnew(istr-1,j)=0.0_r8
1699 END DO
1700 END IF
1701 END IF
1702#endif
1703!
1704!-----------------------------------------------------------------------
1705! Adjoint of time step 2D momentum equations.
1706!-----------------------------------------------------------------------
1707!
1708! Compute adjoint integral mass flux across open boundaries and adjust
1709! for volume conservation.
1710!
1711 IF (any(volcons(:,ng))) THEN
1712!^ CALL tl_obc_flux_tile (ng, tile, &
1713!^ & LBi, UBi, LBj, UBj, &
1714!^ & IminS, ImaxS, JminS, JmaxS, &
1715!^ & knew, &
1716#ifdef MASKING
1717!^ & umask, vmask, &
1718#endif
1719!^ & h, tl_h, om_v, on_u, &
1720!^ & ubar, vbar, zeta, &
1721!^ & tl_ubar, tl_vbar, tl_zeta)
1722!^
1723 CALL ad_obc_flux_tile (ng, tile, &
1724 & lbi, ubi, lbj, ubj, &
1725 & imins, imaxs, jmins, jmaxs, &
1726 & knew, &
1727#ifdef MASKING
1728 & umask, vmask, &
1729#endif
1730 & h, ad_h, om_v, on_u, &
1731 & ubar, vbar, zeta, &
1732 & ad_ubar, ad_vbar, ad_zeta)
1733
1734 END IF
1735!
1736! Apply adjoint ateral boundary conditions.
1737!
1738!^ CALL tl_v2dbc_tile (ng, tile, &
1739!^ & LBi, UBi, LBj, UBj, &
1740!^ & IminS, ImaxS, JminS, JmaxS, &
1741!^ & krhs, kstp, knew, &
1742!^ & ubar, vbar, zeta, &
1743!^ & tl_ubar, tl_vbar, tl_zeta)
1744!^
1745 CALL ad_v2dbc_tile (ng, tile, &
1746 & lbi, ubi, lbj, ubj, &
1747 & imins, imaxs, jmins, jmaxs, &
1748 & krhs, kstp, knew, &
1749 & ubar, vbar, zeta, &
1750 & ad_ubar, ad_vbar, ad_zeta)
1751!^ CALL tl_u2dbc_tile (ng, tile, &
1752!^ & LBi, UBi, LBj, UBj, &
1753!^ & IminS, ImaxS, JminS, JmaxS, &
1754!^ & krhs, kstp, knew, &
1755!^ & ubar, vbar, zeta, &
1756!^ & tl_ubar, tl_vbar, tl_zeta)
1757!^
1758 CALL ad_u2dbc_tile (ng, tile, &
1759 & lbi, ubi, lbj, ubj, &
1760 & imins, imaxs, jmins, jmaxs, &
1761 & krhs, kstp, knew, &
1762 & ubar, vbar, zeta, &
1763 & ad_ubar, ad_vbar, ad_zeta)
1764!
1765! Advance 2D momentum components while simultaneously adding them to
1766! accumulate fast-time averages to compute barotropic fluxes. Doing so
1767! straight away yields a more computationally dense code. However, the
1768! fast-time averaged fluxes (DU_avg1 and DV_avg1) are needed both at
1769! the interior and physical boundary points. Thus, we need separate
1770! loops along the domain boundaries after setting "ubar" and "vbar"
1771! lateral boundary conditions. Also, note that bottom drag is treated
1772! implicitly:
1773!
1774! Dnew*ubar(:,:,m+1) = Dold*ubar(:,:,m) +
1775! dtfast(ng)*rhs2D(:,:) -
1776! dtfast(ng)*rdrag(:,:)*ubar(:,:,m+1)
1777! hence
1778!
1779! ubar(:,:,m+1)=[Dold * ubar(..,m) + dtfast(ng) * rhs2D(:,:)] /
1780! [Dnew + dtfast(ng) * rdrag(:,:)]
1781!
1782! DU_avg1 = DU_avg1 +
1783! weight(m+1) * Dnew * ubar(:,:,m+1) * on_u(:,:)
1784!
1785! where it should be noted that Dnew .ne. Dnew + dtfast * rdrag
1786!
1787 cff=0.5_r8*dtfast(ng)
1788#ifdef SOLVE3D
1789 cff1=0.5_r8*weight(1,iif(ng),ng)
1790#else
1791 cff2=2.0_r8*dtfast(ng)
1792#endif
1793 DO j=jstrv,jend
1794 DO i=istr,iend
1795#if defined NESTING && !defined SOLVE3D
1796!^ tl_DV_flux(i,j)=0.5_r8*om_v(i,j)* &
1797!^ & ((Dnew(i,j)+Dnew(i,j-1))* &
1798!^ & tl_vbar(i,j,knew)+ &
1799!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))* &
1800!^ & vbar(i,j,knew))
1801!^
1802 adfac=0.5_r8*om_v(i,j)*ad_dv_flux(i,j)
1803 adfac1=adfac*vbar(i,j,knew)
1804 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1805 & (dnew(i,j)+dnew(i,j-1))*adfac
1806 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1807 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1808 ad_dv_flux(i,j)=0.0_r8
1809#endif
1810#ifdef SOLVE3D
1811!^ tl_DV_avg1(i,j)=tl_DV_avg1(i,j)+ &
1812!^ & cff1*om_v(i,j)* &
1813!^ & ((Dnew(i,j)+Dnew(i,j-1))* &
1814!^ & tl_vbar(i,j,knew)+ &
1815!^ & (tl_Dnew(i,j)+tl_Dnew(i,j-1))* &
1816!^ & vbar(i,j,knew))
1817!^
1818 adfac=cff1*om_v(i,j)*ad_dv_avg1(i,j)
1819 adfac1=adfac*vbar(i,j,knew)
1820 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)+ &
1821 & (dnew(i,j)+dnew(i,j-1))*adfac
1822 ad_dnew(i,j-1)=ad_dnew(i,j-1)+adfac1
1823 ad_dnew(i,j )=ad_dnew(i,j )+adfac1
1824#endif
1825#ifdef WET_DRY_NOT_YET
1826!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
1827!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
1828!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1829!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
1830!^
1831!^ HGA: ADM code needed here.
1832!^
1833#endif
1834#ifdef MASKING
1835!^ tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
1836!^
1837 ad_vbar(i,j,knew)=ad_vbar(i,j,knew)*vmask(i,j)
1838#endif
1839 cff3=cff*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
1840 fac2=1.0_r8/(dnew_rd(i,j)+dnew_rd(i,j-1))
1841!^ tl_vbar(i,j,knew)=tl_fac2* &
1842!^ & ((Dstp(i,j)+Dstp(i,j-1))*vbar(i,j,kstp)+ &
1843#ifdef SOLVE3D
1844!^ & cff3*(rvbar(i,j)+rvfrc(i,j)))+ &
1845#else
1846!^ & cff3*rvbar(i,j)+cff2*svstr(i,j))+ &
1847#endif
1848!^ & fac2* &
1849!^ & ((Dstp(i,j)+Dstp(i,j-1))* &
1850!^ & tl_vbar(i,j,kstp)+ &
1851!^ & (tl_Dstp(i,j)+tl_Dstp(i,j-1))* &
1852!^ & vbar(i,j,kstp)+ &
1853#ifdef SOLVE3D
1854!^ & cff3*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
1855#else
1856!^ & cff3*tl_rvbar(i,j)+cff2*tl_svstr(i,j))
1857#endif
1858!^
1859 adfac=fac2*ad_vbar(i,j,knew)
1860 adfac1=adfac*(dstp(i,j)+dstp(i,j-1))
1861 adfac2=adfac*cff3
1862 adfac3=adfac*vbar(i,j,kstp)
1863 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+adfac1
1864#ifdef SOLVE3D
1865 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1866 ad_rvfrc(i,j)=ad_rvfrc(i,j)+adfac2
1867#else
1868 ad_rvbar(i,j)=ad_rvbar(i,j)+adfac2
1869 ad_svstr(i,j)=ad_svstr(i,j)+cff2*adfac
1870#endif
1871 ad_dstp(i,j-1)=ad_dstp(i,j-1)+adfac3
1872 ad_dstp(i,j )=ad_dstp(i,j )+adfac3
1873 ad_fac2=ad_fac2+ &
1874 & ad_vbar(i,j,knew)* &
1875 & ((dstp(i,j)+dstp(i,j-1))*vbar(i,j,kstp)+ &
1876#ifdef SOLVE3D
1877 & cff3*(rvbar(i,j)+rvfrc(i,j)))
1878#else
1879 & cff3*rvbar(i,j)+cff2*svstr(i,j))
1880#endif
1881 ad_vbar(i,j,knew)=0.0_r8
1882!^ tl_fac2=-fac2*fac2*(tl_Dnew_rd(i,j)+tl_Dnew_rd(i,j-1))
1883!^
1884 adfac=-fac2*fac2*ad_fac2
1885 ad_dnew_rd(i,j-1)=ad_dnew_rd(i,j-1)+adfac
1886 ad_dnew_rd(i,j )=ad_dnew_rd(i,j )+adfac
1887 ad_fac2=0.0_r8
1888 END DO
1889 END DO
1890!
1891 DO j=jstr,jend
1892 DO i=istru,iend
1893#if defined NESTING && !defined SOLVE3D
1894!^ tl_DU_flux(i,j)=0.5_r8*on_u(i,j)* &
1895!^ & ((Dnew(i,j)+Dnew(i-1,j))* &
1896!^ & tl_ubar(i,j,knew)+ &
1897!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))* &
1898!^ & ubar(i,j,knew))
1899!^
1900 adfac=0.5_r8*on_u(i,j)*ad_du_flux(i,j)
1901 adfac1=adfac*ubar(i,j,knew)
1902 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1903 & (dnew(i,j)+dnew(i-1,j))*adfac
1904 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1905 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1906 ad_du_flux(i,j)=0.0_r8
1907#endif
1908#ifdef SOLVE3D
1909!^ tl_DU_avg1(i,j)=tl_DU_avg1(i,j)+ &
1910!^ & cff1*on_u(i,j)* &
1911!^ & ((Dnew(i,j)+Dnew(i-1,j))* &
1912!^ & tl_ubar(i,j,knew)+ &
1913!^ & (tl_Dnew(i,j)+tl_Dnew(i-1,j))* &
1914!^ & ubar(i,j,knew))
1915!^
1916 adfac=cff1*on_u(i,j)*ad_du_avg1(i,j)
1917 adfac1=adfac*ubar(i,j,knew)
1918 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)+ &
1919 & (dnew(i,j)+dnew(i-1,j))*adfac
1920 ad_dnew(i-1,j)=ad_dnew(i-1,j)+adfac1
1921 ad_dnew(i ,j)=ad_dnew(i ,j)+adfac1
1922#endif
1923#ifdef WET_DRY_NOT_YET
1924!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
1925!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
1926!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
1927!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
1928!^
1929!^ HGA: TLM code needed here.
1930!^
1931#endif
1932#ifdef MASKING
1933!^ tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
1934!^
1935 ad_ubar(i,j,knew)=ad_ubar(i,j,knew)*umask(i,j)
1936#endif
1937 cff3=cff*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
1938 fac1=1.0_r8/(dnew_rd(i,j)+dnew_rd(i-1,j))
1939!^ tl_ubar(i,j,knew)=tl_fac1* &
1940!^ & ((Dstp(i,j)+Dstp(i-1,j))*ubar(i,j,kstp)+ &
1941#ifdef SOLVE3D
1942!^ & cff3*(rubar(i,j)+rufrc(i,j)))+ &
1943#else
1944!^ & cff3*rubar(i,j)+cff2*sustr(i,j))+ &
1945#endif
1946!^ & fac1* &
1947!^ & ((Dstp(i,j)+Dstp(i-1,j))* &
1948!^ & tl_ubar(i,j,kstp)+ &
1949!^ & (tl_Dstp(i,j)+tl_Dstp(i-1,j))* &
1950!^ & ubar(i,j,kstp)+ &
1951#ifdef SOLVE3D
1952!^ & cff3*(tl_rubar(i,j)+tl_rufrc(i,j)))
1953#else
1954!^ & cff3*tl_rubar(i,j)+cff2*tl_sustr(i,j))
1955#endif
1956!>
1957 adfac=fac1*ad_ubar(i,j,knew)
1958 adfac1=adfac*(dstp(i,j)+dstp(i-1,j))
1959 adfac2=adfac*cff3
1960 adfac3=adfac*ubar(i,j,kstp)
1961 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+adfac1
1962#ifdef SOLVE3D
1963 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
1964 ad_rufrc(i,j)=ad_rufrc(i,j)+adfac2
1965#else
1966 ad_rubar(i,j)=ad_rubar(i,j)+adfac2
1967 ad_sustr(i,j)=ad_sustr(i,j)+cff2*adfac
1968#endif
1969 ad_dstp(i-1,j)=ad_dstp(i-1,j)+adfac3
1970 ad_dstp(i ,j)=ad_dstp(i ,j)+adfac3
1971 ad_fac1=ad_fac1+ &
1972 & ad_ubar(i,j,knew)* &
1973 & ((dstp(i,j)+dstp(i-1,j))*ubar(i,j,kstp)+ &
1974#ifdef SOLVE3D
1975 & cff3*(rubar(i,j)+rufrc(i,j)))
1976#else
1977 & cff3*rubar(i,j)+cff2*sustr(i,j))
1978#endif
1979 ad_ubar(i,j,knew)=0.0_r8
1980!^ tl_fac1=-fac1*fac1*(tl_Dnew_rd(i,j)+tl_Dnew_rd(i-1,j))
1981!^
1982 adfac=-fac1*fac1*ad_fac1
1983 ad_dnew_rd(i-1,j)=ad_dnew_rd(i-1,j)+adfac
1984 ad_dnew_rd(i ,j)=ad_dnew_rd(i ,j)+adfac
1985 ad_fac1=0.0_r8
1986 END DO
1987 END DO
1988
1989#if defined UV_QDRAG && !defined SOLVE3D
1990!
1991! Adjoint of add quadratic drag term associated in shallow-water
1992! applications.
1993!
1994! Here, the SQRT(3) is due to a linear interpolation with second order
1995! accuaracy that ensures positive and negative values of the velocity
1996! components:
1997!
1998! u^2(i+1/2) = (1/3)*[u(i)*u(i) + u(i)*u(i+1) + u(i+1)*u(i+1)]
1999!
2000! If u(i)=1 and u(i+1)=-1, then u^2(i+1/2)=1/3 as it should be.
2001!
2002 cff=dtfast(ng)/sqrt(3.0_r8)
2003 DO j=jstrv-1,jend
2004 DO i=istru-1,iend
2005 cff1=ubar(i ,j,kstp)**2+ &
2006 & ubar(i+1,j,kstp)**2+ &
2007 & ubar(i ,j,kstp)*ubar(i+1,j,kstp)+ &
2008 & vbar(i,j ,kstp)**2+ &
2009 & vbar(i,j+1,kstp)**2+ &
2010 & vbar(i,j ,kstp)*vbar(i,j+1,kstp)
2011 cff2=sqrt(cff1)
2012!^ tl_Dnew_rd(i,j)=tl_Dnew_rd(i,j)+ &
2013!^ & cff*rdrag2(i,j)*tl_cff2
2014!^
2015 ad_cff2=ad_cff2+ &
2016 & cff*rdrag2(i,j)*ad_dnew_rd(i,j)
2017!^ tl_cff2=0.5_r8*tl_cff1/cff2
2018!^
2019 ad_cff1=ad_cff1+0.5_r8*ad_cff2/cff2
2020 ad_cff2=0.0_r8
2021!^ tl_cff1=2.0_r8*ubar(i ,j,kstp)*tl_ubar(i ,j,kstp)+ &
2022!^ & 2.0_r8*ubar(i+1,j,kstp)*tl_ubar(i+1,j,kstp)+ &
2023!^ & tl_ubar(i ,j,kstp)*ubar(i+1,j,kstp)+ &
2024!^ & tl_ubar(i+1,j,kstp)*ubar(i ,j,kstp)+ &
2025!^ & 2.0_r8*vbar(i,j ,kstp)*tl_vbar(i,j ,kstp)+ &
2026!^ & 2.0_r8*vbar(i,j+1,kstp)*tl_vbar(i,j+1,kstp)+ &
2027!^ & tl_vbar(i,j ,kstp)*vbar(i,j+1,kstp)+ &
2028!^ & tl_vbar(i,j+1,kstp)*vbar(i,j ,kstp)
2029!^
2030 adfac=2.0_r8*ad_cff1
2031 ad_ubar(i ,j,kstp)=ad_ubar(i ,j,kstp)+ &
2032 & ubar(i ,j,kstp)*adfac+ &
2033 & ubar(i+1,j,kstp)*ad_cff1
2034 ad_ubar(i+1,j,kstp)=ad_ubar(i+1,j,kstp)+ &
2035 & ubar(i+1,j,kstp)*adfac+ &
2036 & ubar(i ,j,kstp)*ad_cff1
2037 ad_vbar(i,j ,kstp)=ad_vbar(i,j ,kstp)+ &
2038 & vbar(i,j ,kstp)*adfac+ &
2039 & vbar(i,j+1,kstp)*ad_cff1
2040 ad_vbar(i,j+1,kstp)=ad_vbar(i,j+1,kstp)+ &
2041 & vbar(i,j+1,kstp)*adfac+ &
2042 & vbar(i,j ,kstp)*ad_cff1
2043 ad_cff1=0.0_r8
2044 END DO
2045 END DO
2046#endif
2047!
2048! Adjoint of compute depths.
2049!
2050 DO j=jstrv-1,jend
2051 DO i=istru-1,iend
2052!^ tl_Dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kstp)
2053!^
2054 ad_h(i,j)=ad_h(i,j)+ad_dstp(i,j)
2055 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_dstp(i,j)
2056 ad_dstp(i,j)=0.0_r8
2057!^ tl_Dnew_rd(i,j)=tl_Dnew(i,j)
2058!^
2059 ad_dnew(i,j)=ad_dnew(i,j)+ad_dnew_rd(i,j)
2060 ad_dnew_rd(i,j)=0.0_r8
2061!^ tl_Dnew(i,j)=tl_h(i,j)+tl_zeta_new(i,j)
2062!^
2063 ad_h(i,j)=ad_h(i,j)+ad_dnew(i,j)
2064 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_dnew(i,j)
2065 ad_dnew(i,j)=0.0_r8
2066 END DO
2067 END DO
2068
2069#ifdef SOLVE3D
2070!
2071!-----------------------------------------------------------------------
2072! Coupling between 2D and 3D equations.
2073!-----------------------------------------------------------------------
2074!
2075! Before the first barotropic time step, arrays "rufrc" and "rvfrc"
2076! contain vertical integrals of the 3D right-hand-side terms for the
2077! momentum equations (including surface and bottom stresses). During
2078! the first barotropic time step, convert them into forcing terms by
2079! subtracting the fast-time "rubar" and "rvbar" from them.
2080!
2081! In the predictor-coupled mode, the resultant forcing terms "rufrc"
2082! and "rvfrc" are extrapolated forward in time, so they become
2083! centered effectively at time n+1/2. This is done using optimized
2084! Adams-Bashforth weights. In the code below, rufrc_bak(:,:,nstp) is
2085! at (n-1)time step, while rufrc_bak(:,:,3-nstp) is at (n-2). After
2086! its use as input, the latter is overwritten by the value at time
2087! step "nstp" (mathematically "n") during the next step.
2088!
2089! From now on, the computed forcing terms "rufrc" and "rvfrc" will
2090! remain constant during the fast-time stepping and will be added
2091! to "rubar" and "rvbar" during all subsequent barotropic steps.
2092!
2093 coupled_step : IF (first_2d_step) THEN
2094!
2095! Predictor coupled barotropic mode: Set coefficients for AB3-like
2096! forward-in-time extrapolation of 3D to 2D forcing terms "rufrc" and
2097! "rvfrc".
2098!
2099 IF (iic(ng).eq.ntstart(ng)) THEN
2100 cfwd0=1.0_r8
2101 cfwd1=0.0_r8
2102 cfwd2=0.0_r8
2103 ELSE IF (iic(ng).eq.ntstart(ng)+1) THEN
2104 cfwd0=1.5_r8
2105 cfwd1=-0.5_r8
2106 cfwd2=0.0_r8
2107 ELSE
2108 cfwd2=0.281105_r8
2109 cfwd1=-0.5_r8-2.0_r8*cfwd2
2110 cfwd0=1.5_r8+cfwd2
2111 END IF
2112!
2113 cff1=0.5*g
2114# if defined VAR_RHO_2D && defined SOLVE3D
2115 cff2=0.333333333333_r8
2116# endif
2117!
2118 DO j=jstr,jend
2119 DO i=istr,iend
2120 IF (j.ge.jstrv) THEN
2121# ifdef DIAGNOSTICS_UV
2122!! DiaV2rhs(i,j,M2pgrd)=DiaV2rhs(i,j,M2pgrd)+ &
2123!! & rvbar(i,j)
2124# endif
2125!^ tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2126!^ & cff1*om_v(i,j)* &
2127!^ & ((tl_h(i,j-1)+ &
2128!^ & tl_h(i,j ))* &
2129!^ & (rzeta(i,j-1)- &
2130!^ & rzeta(i,j ))+ &
2131!^ & (h(i,j-1)+ &
2132!^ & h(i,j ))* &
2133!^ & (tl_rzeta(i,j-1)- &
2134!^ & tl_rzeta(i,j ))+ &
2135# if defined VAR_RHO_2D && defined SOLVE3D
2136!^ & (tl_h(i,j-1)- &
2137!^ & tl_h(i,j ))* &
2138!^ & (rzetaSA(i,j-1)+ &
2139!^ & rzetaSA(i,j )+ &
2140!^ & cff2*(rhoA(i,j-1)- &
2141!^ & rhoA(i,j ))* &
2142!^ & (zwrk(i,j-1)- &
2143!^ & zwrk(i,j )))+ &
2144!^ & (h(i,j-1)- &
2145!^ & h(i,j ))* &
2146!^ & (tl_rzetaSA(i,j-1)+ &
2147!^ & tl_rzetaSA(i,j )+ &
2148!^ & cff2*((tl_rhoA(i,j-1)- &
2149!^ & tl_rhoA(i,j ))* &
2150!^ & (zwrk(i,j-1)- &
2151!^ & zwrk(i,j ))+ &
2152!^ & (rhoA(i,j-1)- &
2153!^ & rhoA(i,j ))* &
2154!^ & (tl_zwrk(i,j-1)- &
2155!^ & tl_zwrk(i,j ))))+ &
2156# endif
2157!^ & (tl_rzeta2(i,j-1)- &
2158!^ & tl_rzeta2(i,j )))
2159!^
2160 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
2161 adfac1=adfac*(rzeta(i,j-1)-rzeta(i,j ))
2162 adfac2=adfac*(h(i,j-1)-h(i,j ))
2163 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
2164 ad_h(i,j )=ad_h(i,j )+adfac1
2165 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac2
2166 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2
2167 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac
2168 ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac
2169# if defined VAR_RHO_2D && defined SOLVE3D
2170 adfac3=adfac*(rzetasa(i,j-1)+ &
2171 & rzetasa(i,j )+ &
2172 & cff2*(rhoa(i,j-1)- &
2173 & rhoa(i,j ))* &
2174 & (zwrk(i,j-1)- &
2175 & zwrk(i,j )))
2176 adfac4=adfac2*cff2*(zwrk(i,j-1)-zwrk(i,j))
2177 adfac5=adfac2*cff2*(rhoa(i,j-1)-rhoa(i,j))
2178 ad_h(i,j-1)=ad_h(i,j-1)+adfac3
2179 ad_h(i,j )=ad_h(i,j )-adfac3
2180 ad_rzetasa(i,j-1)=ad_rzetasa(i,j-1)+adfac2
2181 ad_rzetasa(i,j )=ad_rzetasa(i,j )+adfac2
2182 ad_rhoa(i,j-1)=ad_rhoa(i,j-1)+adfac4
2183 ad_rhoa(i,j )=ad_rhoa(i,j )-adfac4
2184 ad_zwrk(i,j-1)=ad_zwrk(i,j-1)+adfac5
2185 ad_zwrk(i,j )=ad_zwrk(i,j )-adfac5
2186# endif
2187 END IF
2188!
2189 IF (i.ge.istru) THEN
2190# ifdef DIAGNOSTICS_UV
2191!! DiaU2rhs(i,j,M2pgrd)=DiaU2rhs(i,j,M2pgrd)+ &
2192!! & rubar(i,j)
2193# endif
2194!^ tl_rubar(i,j)=tl_rubar(i,j)+ &
2195!^ & cff1*on_u(i,j)* &
2196!^ & ((tl_h(i-1,j)+ &
2197!^ & tl_h(i ,j))* &
2198!^ & (rzeta(i-1,j)- &
2199!^ & rzeta(i ,j))+ &
2200!^ & (h(i-1,j)+ &
2201!^ & h(i ,j))* &
2202!^ & (tl_rzeta(i-1,j)- &
2203!^ & tl_rzeta(i ,j))+ &
2204# if defined VAR_RHO_2D && defined SOLVE3D
2205!^ & (tl_h(i-1,j)- &
2206!^ & tl_h(i ,j))* &
2207!^ & (rzetaSA(i-1,j)+ &
2208!^ & rzetaSA(i ,j)+ &
2209!^ & cff2*(rhoA(i-1,j)- &
2210!^ & rhoA(i ,j))* &
2211!^ & (zwrk(i-1,j)- &
2212!^ & zwrk(i ,j)))+ &
2213!^ & (h(i-1,j)- &
2214!^ & h(i ,j))* &
2215!^ & (tl_rzetaSA(i-1,j)+ &
2216!^ & tl_rzetaSA(i ,j)+ &
2217!^ & cff2*((tl_rhoA(i-1,j)- &
2218!^ & tl_rhoA(i ,j))* &
2219!^ & (zwrk(i-1,j)- &
2220!^ & zwrk(i ,j))+ &
2221!^ & (rhoA(i-1,j)- &
2222!^ & rhoA(i ,j))* &
2223!^ & (tl_zwrk(i-1,j)- &
2224!^ & tl_zwrk(i ,j))))+ &
2225# endif
2226!^ & (tl_rzeta2(i-1,j)- &
2227!^ & tl_rzeta2(i ,j)))
2228!^
2229 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
2230 adfac1=adfac*(rzeta(i-1,j)-rzeta(i ,j))
2231 adfac2=adfac*(h(i-1,j)+h(i ,j))
2232 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
2233 ad_h(i ,j)=ad_h(i ,j)+adfac1
2234 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac2
2235 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2
2236 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac
2237 ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac
2238# if defined VAR_RHO_2D && defined SOLVE3D
2239 adfac3=adfac*(rzetasa(i-1,j)+ &
2240 & rzetasa(i ,j)+ &
2241 & cff2*(rhoa(i-1,j)- &
2242 & rhoa(i ,j))* &
2243 & (zwrk(i-1,j)- &
2244 & zwrk(i ,j)))
2245 adfac4=adfac2*cff2*(zwrk(i-1,j)-zwrk(i,j))
2246 adfac5=adfac2*cff2*(rhoa(i-1,j)-rhoa(i,j))
2247 ad_h(i-1,j)=ad_h(i-1,j)+adfac3
2248 ad_h(i ,j)=ad_h(i ,j)-adfac3
2249 ad_rzetasa(i-1,j)=ad_rzetasa(i-1,j)+adfac2
2250 ad_rzetasa(i ,j)=ad_rzetasa(i ,j)+adfac2
2251 ad_rhoa(i-1,j)=ad_rhoa(i-1,j)+adfac4
2252 ad_rhoa(i ,j)=ad_rhoa(i ,j)-adfac4
2253 ad_zwrk(i-1,j)=ad_zwrk(i-1,j)+adfac5
2254 ad_zwrk(i ,j)=ad_zwrk(i ,j)-adfac5
2255# endif
2256 END IF
2257 END DO
2258 END DO
2259!
2260! Add correction term to shift pressure-gradient terms from "kstp" to
2261! "knew". That is, it converts the first 2D step from Forward-Euler
2262! to Forward-Backward (this is PGF_FB_CORRECTION mentioned above).
2263!
2264 DO j=jstrv-1,jend
2265 DO i=istru-1,iend
2266# if defined VAR_RHO_2D && defined SOLVE3D
2267!^ tl_rzetaSA(i,j)=tl_zwrk(i,j)* &
2268!^ & (rhoS(i,j)-rhoA(i,j))+ &
2269!^ & zwrk(i,j)* &
2270!^ & (tl_rhoS(i,j)-tl_rhoA(i,j))
2271!^
2272 adfac=zwrk(i,j)*ad_rzetasa(i,j)
2273 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
2274 & (rhos(i,j)-rhoa(i,j))*ad_rzetasa(i,j)
2275 ad_rhos(i,j)=ad_rhos(i,j)+adfac
2276 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
2277 ad_rzetasa(i,j)=0.0_r8
2278!^ tl_rzeta2(i,j)=tl_rzeta(i,j)* &
2279!^ & (zeta_new(i,j)+zeta(i,j,kstp))+ &
2280!^ & rzeta(i,j)* &
2281!^ & (tl_zeta_new(i,j)+tl_zeta(i,j,kstp))
2282!^
2283 adfac=rzeta(i,j)*ad_rzeta2(i,j)
2284 ad_rzeta(i,j)=ad_rzeta(i,j)+ &
2285 & (zeta_new(i,j)+zeta(i,j,kstp))*ad_rzeta2(i,j)
2286 ad_zeta_new(i,j)=ad_zeta_new(i,j)+adfac
2287 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+adfac
2288 ad_rzeta2(i,j)=0.0_r8
2289!^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ &
2290!^ & tl_rhoS(i,j)*zwrk(i,j)
2291!^
2292 ad_zwrk(i,j)=ad_zwrk(i,j)+(1.0_r8+rhos(i,j))*ad_rzeta(i,j)
2293 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_rzeta(i,j)
2294 ad_rzeta(i,j)=0.0_r8
2295# else
2296!^ tl_rzeta2(i,j)=tl_zwrk(i,j)* &
2297!^ & (zeta_new(i,j)+zeta(i,j,kstp))+ &
2298!^ & zwrk(i,j)* &
2299!^ & (tl_zeta_new(i,j)+tl_zeta(i,j,kstp))
2300!^
2301 adfac=zwrk(i,j)*ad_rzeta2(i,j)
2302 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
2303 & (zeta_new(i,j)+zeta(i,j,kstp))*ad_rzeta2(i,j)
2304 ad_zeta_new(i,j)=ad_zeta_new(i,j)+adfac
2305 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+adfac
2306 ad_rzeta2(i,j)=0.0_r8
2307!^ tl_rzeta(i,j)=tl_zwrk(i,j)
2308!^
2309 ad_zwrk(i,j)=ad_zwrk(i,j)+ad_rzeta(i,j)
2310 ad_rzeta(i,j)=0.0_r8
2311# endif
2312!^ tl_zwrk(i,j)=tl_zeta_new(i,j)-tl_zeta(i,j,kstp)
2313!^
2314 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_zwrk(i,j)
2315 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)-ad_zwrk(i,j)
2316 ad_zwrk(i,j)=0.0_r8
2317 END DO
2318 END DO
2319!
2320! Barotropic mode running predictor stage: forward extrapolation.
2321!
2322 DO j=jstr,jend
2323 DO i=istr,iend
2324 IF (j.ge.jstrv) THEN
2325!^ tl_rvfrc_bak(i,j,3-nstp)=tl_cff2
2326!^
2327 ad_cff2=ad_cff2+ad_rvfrc_bak(i,j,3-nstp)
2328 ad_rvfrc_bak(i,j,3-nstp)=0.0_r8
2329!^ tl_rvfrc(i,j)=cfwd0*tl_cff2+ &
2330!^ & cfwd1*tl_rvfrc_bak(i,j, nstp)+ &
2331!^ & cfwd2*tl_rvfrc_bak(i,j,3-nstp)
2332!^
2333 ad_cff2=ad_cff2+cfwd0*ad_rvfrc(i,j)
2334 ad_rvfrc_bak(i,j, nstp)=ad_rvfrc_bak(i,j, nstp)+ &
2335 & cfwd1*ad_rvfrc(i,j)
2336 ad_rvfrc_bak(i,j,3-nstp)=ad_rvfrc_bak(i,j,3-nstp)+ &
2337 & cfwd2*ad_rvfrc(i,j)
2338 ad_rvfrc(i,j)=0.0_r8
2339!^ tl_cff2=tl_rvfrc(i,j)-tl_rvbar(i,j)
2340!^
2341 ad_rvfrc(i,j)=ad_rvfrc(i,j)+ad_cff2
2342 ad_rvbar(i,j)=ad_rvbar(i,j)-ad_cff2
2343 ad_cff2=0.0_r8
2344 END IF
2345!
2346 IF (i.ge.istru) THEN
2347!^ tl_rufrc_bak(i,j,3-nstp)=tl_cff1
2348!^
2349 ad_cff1=ad_cff1+ad_rufrc_bak(i,j,3-nstp)
2350 ad_rufrc_bak(i,j,3-nstp)=0.0_r8
2351!^ tl_rufrc(i,j)=cfwd0*tl_cff1+ &
2352!^ & cfwd1*tl_rufrc_bak(i,j, nstp)+ &
2353!^ & cfwd2*tl_rufrc_bak(i,j,3-nstp)
2354!^
2355 ad_cff1=ad_cff1+cfwd0*ad_rufrc(i,j)
2356 ad_rufrc_bak(i,j, nstp)=ad_rufrc_bak(i,j, nstp)+ &
2357 & cfwd1*ad_rufrc(i,j)
2358 ad_rufrc_bak(i,j,3-nstp)=ad_rufrc_bak(i,j,3-nstp)+ &
2359 & cfwd2*ad_rufrc(i,j)
2360 ad_rufrc(i,j)=0.0_r8
2361!^ tl_cff1=tl_rufrc(i,j)-tl_rubar(i,j)
2362!^
2363 ad_rufrc(i,j)=ad_rufrc(i,j)+ad_cff1
2364 ad_rubar(i,j)=ad_rubar(i,j)-ad_cff1
2365 ad_cff1=0.0_r8
2366 END IF
2367!
2368! Compensate for (cancel) bottom drag terms: at input into step2d
2369! "rufrc" and "rvfrc" contain bottom drag terms computed by 3D mode.
2370! However, there are no 2D counterparts in "rubar" and "rvbar" because
2371! 2D bottom drag will be computed implicitly during the final stage of
2372! updating ubar(:,:,knew) and vbar(:,:,knew) below. Note that unlike
2373! the other terms, the bottom drag should not be extrapolated forward,
2374! if "rufrc" and "rvfrc" are, so this cancelation needs to be done
2375! right now rather than at the bottom of this loop.
2376!
2377 IF (j.ge.jstrv) THEN
2378!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)+ &
2379!^ & 0.5_r8*(rdrag(i,j)+rdrag(i,j-1))* &
2380!^ & om_v(i,j)*on_v(i,j)*tl_vbar(i,j,kstp)
2381!^
2382 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+ &
2383 & 0.5_r8*(rdrag(i,j)+rdrag(i,j-1))* &
2384 & om_v(i,j)*on_v(i,j)*ad_rvfrc(i,j)
2385 END IF
2386
2387 IF (i.ge.istru) THEN
2388!^ tl_rufrc(i,j)=tl_rufrc(i,j)+ &
2389!^ & 0.5_r8*(rdrag(i,j)+rdrag(i-1,j))* &
2390!^ & om_u(i,j)*on_u(i,j)*tl_ubar(i,j,kstp)
2391!^
2392 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+ &
2393 & 0.5_r8*(rdrag(i,j)+rdrag(i-1,j))* &
2394 & om_u(i,j)*on_u(i,j)*ad_rufrc(i,j)
2395 END IF
2396 END DO
2397 END DO
2398!
2399 END IF coupled_step
2400#endif
2401!
2402!=======================================================================
2403! Adjoint of compute right-hand-side for the 2D momentum equations.
2404!=======================================================================
2405#ifdef SOLVE3D
2406!
2407! Notice that we are suppressing the computation of momentum advection,
2408! Coriolis, and lateral viscosity terms in 3D Applications because
2409! these terms are already included in the baroclinic-to-barotropic
2410! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely
2411! omitting them, but it is a choice between recomputing them at every
2412! barotropic step or keeping them "frozen" during the fast-time
2413! stepping.
2414# ifdef STEP2D_CORIOLIS
2415! However, in some coarse grid applications with larger baroclinic
2416! timestep (say, DT around 20 minutes or larger), adding the Coriolis
2417! term in the barotropic equations is useful since f*DT is no longer
2418! small.
2419# endif
2420#endif
2421
2422#if defined UV_VIS2 && !defined SOLVE3D
2423!
2424!-----------------------------------------------------------------------
2425! Adjoint of Add in horizontal harmonic viscosity.
2426!-----------------------------------------------------------------------
2427!
2428! Compute BASIC STATE total depth at PSI-points.
2429!
2430 DO j=jstr,jend+1
2431 DO i=istr,iend+1
2432 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2433 & drhs(i,j-1)+drhs(i-1,j-1))
2434 END DO
2435 END DO
2436!
2437! Add in harmonic viscosity.
2438!
2439 DO j=jstr,jend
2440 DO i=istr,iend
2441 IF (j.ge.jstrv) THEN
2442# if defined DIAGNOSTICS_UV
2443!! DiaV2rhs(i,j,M2hvis)=fac1
2444!! DiaV2rhs(i,j,M2xvis)= cff1
2445!! DiaV2rhs(i,j,M2yvis)=-cff2
2446# endif
2447!^ tl_rvbar(i,j)=tl_rvbar(i,j)+tl_fac1
2448!^
2449 ad_fac1=ad_fac1+ad_rvbar(i,j)
2450!^ tl_fac1=tl_cff1-tl_cff2
2451!^
2452 ad_cff1=ad_cff1+ad_fac1
2453 ad_cff2=ad_cff2-ad_fac1
2454 ad_fac1=0.0_r8
2455!^ tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2456!^ & (tl_VFe(i ,j)-tl_VFe(i,j-1))
2457!^
2458 adfac=0.5_r8*(pm(i,j-1)+pm(i,j))*ad_cff2
2459 ad_vfe(i,j-1)=ad_vfe(i,j-1)-adfac
2460 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2461 ad_cff2=0.0_r8
2462!^ tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2463!^ & (tl_VFx(i+1,j)-tl_VFx(i,j ))
2464!^
2465 adfac=0.5_r8*(pn(i,j-1)+pn(i,j))*ad_cff1
2466 ad_vfx(i ,j)=ad_vfx(i ,j)-adfac
2467 ad_vfx(i+1,j)=ad_vfx(i+1,j)+adfac
2468 ad_cff1=0.0_r8
2469 END IF
2470!
2471 IF (i.ge.istru) THEN
2472# if defined DIAGNOSTICS_UV
2473!! DiaU2rhs(i,j,M2hvis)=fac1
2474!! DiaU2rhs(i,j,M2xvis)=cff1
2475!! DiaU2rhs(i,j,M2yvis)=cff2
2476# endif
2477!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2478!^
2479 ad_fac1=ad_fac1+ad_rubar(i,j)
2480!^ tl_fac1=tl_cff1+tl_cff2
2481!^
2482 ad_cff1=ad_cff1+ad_fac1
2483 ad_cff2=ad_cff2+ad_fac1
2484 ad_fac1=0.0_r8
2485!^ tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2486!^ & (tl_UFe(i,j+1)-tl_UFe(i ,j))
2487!^
2488 adfac=0.5_r8*(pm(i-1,j)+pm(i,j))*ad_cff2
2489 ad_ufe(i,j )=ad_ufe(i,j )-adfac
2490 ad_ufe(i,j+1)=ad_ufe(i,j+1)+adfac
2491 ad_cff2=0.0_r8
2492!^ tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2493!^ & (tl_UFx(i,j )-tl_UFx(i-1,j))
2494!^
2495 adfac=0.5_r8*(pn(i-1,j)+pn(i,j))*ad_cff1
2496 ad_ufx(i-1,j)=ad_ufx(i-1,j)-adfac
2497 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2498 ad_cff1=0.0_r8
2499 END IF
2500 END DO
2501 END DO
2502!
2503! Compute flux-components of the horizontal divergence of the stress
2504! tensor (m5/s2) in XI- and ETA-directions.
2505!
2506 DO j=jstr,jend+1
2507 DO i=istr,iend+1
2508!^ tl_VFx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2509!^ tl_UFe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2510!^
2511 ad_cff=ad_cff+ &
2512 & on_p(i,j)*on_p(i,j)*ad_vfx(i,j)+ &
2513 & om_p(i,j)*om_p(i,j)*ad_ufe(i,j)
2514 ad_vfx(i,j)=0.0_r8
2515 ad_ufe(i,j)=0.0_r8
2516# ifdef WET_DRY_NOT_YET
2517!^ tl_cff=tl_cff*pmask_wet(i,j)
2518!^
2519 ad_cff=ad_cff*pmask_wet(i,j)
2520# endif
2521# ifdef MASKING
2522!^ tl_cff=tl_cff*pmask(i,j)
2523!^
2524 ad_cff=ad_cff*pmask(i,j)
2525# endif
2526!^ tl_cff=visc2_p(i,j)*0.5_r8* &
2527!^ & (tl_Drhs_p(i,j)* &
2528!^ & (pmon_p(i,j)* &
2529!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,kstp)- &
2530!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,kstp))+ &
2531!^ & pnom_p(i,j)* &
2532!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,kstp)- &
2533!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,kstp)))+ &
2534!^ & Drhs_p(i,j)* &
2535!^ & (pmon_p(i,j)* &
2536!^ & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,kstp)- &
2537!^ & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,kstp))+ &
2538!^ & pnom_p(i,j)* &
2539!^ & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,kstp)- &
2540!^ & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,kstp))))
2541!^
2542 adfac=visc2_p(i,j)*0.5_r8*ad_cff
2543 adfac1=adfac*drhs_p(i,j)
2544 adfac2=adfac1*pmon_p(i,j)
2545 adfac3=adfac1*pnom_p(i,j)
2546 ad_drhs_p(i,j)=ad_drhs_p(i,j)+ &
2547 & (pmon_p(i,j)* &
2548 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,kstp)- &
2549 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,kstp))+ &
2550 & pnom_p(i,j)* &
2551 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,kstp)- &
2552 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,kstp)))* &
2553 & adfac
2554 ad_vbar(i-1,j,kstp)=ad_vbar(i-1,j,kstp)- &
2555 & (pn(i-1,j-1)+pn(i-1,j))*adfac2
2556 ad_vbar(i ,j,kstp)=ad_vbar(i ,j,kstp)+ &
2557 & (pn(i ,j-1)+pn(i ,j))*adfac2
2558 ad_ubar(i,j-1,kstp)=ad_ubar(i,j-1,kstp)- &
2559 & (pm(i-1,j-1)+pm(i,j-1))*adfac3
2560 ad_ubar(i,j ,kstp)=ad_ubar(i,j ,kstp)+ &
2561 & (pm(i-1,j )+pm(i,j ))*adfac3
2562 ad_cff=0.0_r8
2563 END DO
2564 END DO
2565!
2566 DO j=jstrv-1,jend
2567 DO i=istru-1,iend
2568!^ tl_VFe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2569!^ tl_UFx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2570!^
2571 ad_cff=ad_cff+ &
2572 & om_r(i,j)*om_r(i,j)*ad_vfe(i,j)+ &
2573 & on_r(i,j)*on_r(i,j)*ad_ufx(i,j)
2574 ad_vfe(i,j)=0.0_r8
2575 ad_ufx(i,j)=0.0_r8
2576!^ tl_cff=visc2_r(i,j)*0.5_r8* &
2577!^ & (tl_Drhs(i,j)* &
2578!^ & (pmon_r(i,j)* &
2579!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,kstp)- &
2580!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,kstp))- &
2581!^ & pnom_r(i,j)* &
2582!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,kstp)- &
2583!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,kstp)))+ &
2584!^ & Drhs(i,j)* &
2585!^ & (pmon_r(i,j)* &
2586!^ & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,kstp)- &
2587!^ & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,kstp))- &
2588!^ & pnom_r(i,j)* &
2589!^ & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,kstp)- &
2590!^ & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,kstp))))
2591!^
2592 adfac=visc2_r(i,j)*0.5_r8*ad_cff
2593 adfac1=adfac*drhs(i,j)
2594 adfac2=adfac1*pmon_r(i,j)
2595 adfac3=adfac1*pnom_r(i,j)
2596 ad_drhs(i,j)=ad_drhs(i,j)+ &
2597 & (pmon_r(i,j)* &
2598 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,kstp)- &
2599 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,kstp))- &
2600 & pnom_r(i,j)* &
2601 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,kstp)- &
2602 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,kstp)))* &
2603 & adfac
2604 ad_ubar(i ,j,kstp)=ad_ubar(i ,j,kstp)- &
2605 & (pn(i-1,j)+pn(i ,j))*adfac2
2606 ad_ubar(i+1,j,kstp)=ad_ubar(i+1,j,kstp)+ &
2607 & (pn(i ,j)+pn(i+1,j))*adfac2
2608 ad_vbar(i,j ,kstp)=ad_vbar(i,j ,kstp)+ &
2609 & (pm(i,j-1)+pm(i,j ))*adfac3
2610 ad_vbar(i,j+1,kstp)=ad_vbar(i,j+1,kstp)- &
2611 & (pm(i,j )+pm(i,j+1))*adfac3
2612 ad_cff=0.0_r8
2613 END DO
2614 END DO
2615!
2616! Compute total depth at PSI-points.
2617!
2618 DO j=jstr,jend+1
2619 DO i=istr,iend+1
2620!^ tl_Drhs_p(i,j)=0.25_r8*(tl_Drhs(i,j )+tl_Drhs(i-1,j )+ &
2621!^ & tl_Drhs(i,j-1)+tl_Drhs(i-1,j-1))
2622!^
2623 adfac=0.25_r8*ad_drhs_p(i,j)
2624 ad_drhs(i-1,j-1)=ad_drhs(i-1,j-1)+adfac
2625 ad_drhs(i-1,j )=ad_drhs(i-1,j )+adfac
2626 ad_drhs(i, j-1)=ad_drhs(i ,j-1)+adfac
2627 ad_drhs(i ,j )=ad_drhs(i ,j )+adfac
2628 ad_drhs_p(i,j)=0.0_r8
2629 END DO
2630 END DO
2631#endif
2632
2633#if (defined CURVGRID && defined UV_ADV) && !defined SOLVE3D
2634!
2635!-----------------------------------------------------------------------
2636! Adjoint of add in curvilinear transformation terms.
2637!-----------------------------------------------------------------------
2638!
2639 DO j=jstr,jend
2640 DO i=istr,iend
2641 IF (j.ge.jstrv) THEN
2642# if defined DIAGNOSTICS_UV
2643!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
2644!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
2645!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
2646!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
2647# endif
2648!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac1
2649!^
2650 ad_fac1=ad_fac1-ad_rvbar(i,j)
2651!^ tl_fac1=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
2652!^
2653 adfac=0.5_r8*ad_fac1
2654 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
2655 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2656 ad_fac1=0.0_r8
2657 END IF
2658!
2659 IF (i.ge.istru) THEN
2660# if defined DIAGNOSTICS_UV
2661!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
2662!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
2663!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
2664!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
2665# endif
2666!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2667!^
2668 ad_fac1=ad_fac1+ad_rubar(i,j)
2669!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
2670!^
2671 adfac=0.5_r8*ad_fac1
2672 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
2673 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2674 ad_fac1=0.0_r8
2675 END IF
2676 END DO
2677 END DO
2678!
2679 DO j=jstrv-1,jend
2680 DO i=istru-1,iend
2681 cff1=0.5_r8*(vrhs(i,j )+ &
2682# ifdef WEC_MELLOR
2683 & vbar_stokes(i,j )+ &
2684 & vbar_stokes(i,j+1)+ &
2685# endif
2686 & vrhs(i,j+1))
2687 cff2=0.5_r8*(urhs(i ,j)+
2688# ifdef WEC_MELLOR
2689 & ubar_stokes(i ,j)+ &
2690 & ubar_stokes(i+1,j)+ &
2691# endif
2692 & urhs(i+1,j))
2693 cff3=cff1*dndx(i,j)
2694 cff4=cff2*dmde(i,j)
2695 cff=drhs(i,j)*(cff3-cff4)
2696# if defined DIAGNOSTICS_UV
2697!! cff=Drhs(i,j)*cff4
2698!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
2699!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
2700# endif
2701!^ tl_VFe(i,j)=tl_cff*cff2+cff*tl_cff2
2702!^ tl_UFx(i,j)=tl_cff*cff1+cff*tl_cff1
2703!^
2704 ad_cff=ad_cff+ &
2705 & cff1*ad_ufx(i,j)+ &
2706 & cff2*ad_vfe(i,j)
2707 ad_cff1=ad_cff1+cff*ad_ufx(i,j)
2708 ad_cff2=ad_cff2+cff*ad_vfe(i,j)
2709 ad_ufx(i,j)=0.0_r8
2710 ad_vfe(i,j)=0.0_r8
2711!^ tl_cff=tl_Drhs(i,j)*(cff3-cff4)+ &
2712!^ & Drhs(i,j)*(tl_cff3-tl_cff4)
2713!^
2714 adfac=drhs(i,j)*ad_cff
2715 ad_cff4=ad_cff4-adfac
2716 ad_cff3=ad_cff3+adfac
2717 ad_drhs(i,j)=ad_drhs(i,j)+(cff3-cff4)*ad_cff
2718 ad_cff=0.0_r8
2719!^ tl_cff4=tl_cff2*dmde(i,j)
2720!^
2721 ad_cff2=ad_cff2+dmde(i,j)*ad_cff4
2722 ad_cff4=0.0_r8
2723!^ tl_cff3=tl_cff1*dndx(i,j)
2724!^
2725 ad_cff1=ad_cff1+dndx(i,j)*ad_cff3
2726 ad_cff3=0.0_r8
2727!^ tl_cff2=0.5_r8*(tl_urhs(i ,j)+ &
2728# ifdef WEC_MELLOR
2729!^ & tl_ubar_stokes(i ,j)+ &
2730!^ & tl_ubar_stokes(i+1,j)+ &
2731# endif
2732!^ & tl_urhs(i+1,j))
2733!^
2734 adfac=0.5_r8*ad_cff2
2735 ad_urhs(i ,j)=ad_urhs(i ,j)+adfac
2736 ad_urhs(i+1,j)=ad_urhs(i+1,j)+adfac
2737# ifdef WEC_MELLOR
2738 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
2739 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
2740# endif
2741 ad_cff2=0.0_r8
2742!^ tl_cff1=0.5_r8*(tl_vrhs(i,j )+ &
2743# ifdef WEC_MELLOR
2744!^ & tl_vbar_stokes(i,j )+ &
2745!^ & tl_vbar_stokes(i,j+1)+ &
2746# endif
2747!^ & tl_vrhs(i,j+1))
2748!^
2749 adfac=0.5_r8*ad_cff1
2750 ad_vrhs(i,j )=ad_vrhs(i,j )+adfac
2751 ad_vrhs(i,j+1)=ad_vrhs(i,j+1)+adfac
2752# ifdef WEC_MELLOR
2753 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
2754 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
2755# endif
2756 ad_cff1=0.0_r8
2757 END DO
2758 END DO
2759#endif
2760
2761#if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
2762!
2763!-----------------------------------------------------------------------
2764! Adjoint of add in Coriolis term.
2765!-----------------------------------------------------------------------
2766!
2767 DO j=jstr,jend
2768 DO i=istr,iend
2769 IF (j.ge.jstrv) THEN
2770# if defined DIAGNOSTICS_UV
2771!! DiaV2rhs(i,j,M2fcor)=-fac2
2772# endif
2773!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
2774!^
2775 ad_fac2=ad_fac2-ad_rvbar(i,j)
2776!^ tl_fac2=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
2777!^
2778 adfac=0.5_r8*ad_fac2
2779 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
2780 ad_vfe(i,j )=ad_vfe(i,j )+adfac
2781 ad_fac2=0.0_r8
2782 END IF
2783!
2784 IF (i.ge.istru) THEN
2785# if defined DIAGNOSTICS_UV
2786!! DiaU2rhs(i,j,M2fcor)=fac1
2787# endif
2788!^ tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2789!^
2790 ad_fac1=ad_fac1+ad_rubar(i,j)
2791!^ tl_fac1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
2792!^
2793 adfac=0.5_r8*ad_fac1
2794 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
2795 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
2796 ad_fac1=0.0_r8
2797 END IF
2798 END DO
2799 END DO
2800!
2801 DO j=jstrv-1,jend
2802 DO i=istru-1,iend
2803 cff=0.5_r8*drhs(i,j)*fomn(i,j)
2804!^ tl_VFe(i,j)=tl_cff*(urhs(i ,j)+ &
2805# ifdef WEC_MELLOR
2806!^ & ubar_stokes(i ,j)+ &
2807!^ & ubar_stokes(i+1,j)+ &
2808# endif
2809!^ & urhs(i+1,j))+ &
2810!^ & cff*(tl_urhs(i ,j)+ &
2811# ifdef WEC_MELLOR
2812!^ & tl_ubar_stokes(i ,j)+ &
2813!^ & tl_ubar_stokes(i+1,j)+ &
2814# endif
2815!^ & tl_urhs(i+1,j))
2816!^
2817 adfac=cff*ad_vfe(i,j)
2818 ad_urhs(i ,j)=ad_urhs(i ,j)+adfac
2819 ad_urhs(i+1,j)=ad_urhs(i+1,j)+adfac
2820# ifdef WEC_MELLOR
2821 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac
2822 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac
2823# endif
2824 ad_cff=ad_cff+ &
2825 & (urhs(i ,j)+ &
2826# ifdef WEC_MELLOR
2827 & ubar_stokes(i ,j)+ &
2828 & ubar_stokes(i+1,j)+ &
2829# endif
2830 & urhs(i+1,j))*ad_vfe(i,j)
2831 ad_vfe(i,j)=0.0_r8
2832!
2833!^ tl_UFx(i,j)=tl_cff*(vrhs(i,j )+ &
2834# ifdef WEC_MELLOR
2835!^ & vbar_stokes(i,j )+ &
2836!^ & vbar_stokes(i,j+1)+ &
2837# endif
2838!^ & vrhs(i,j+1))+ &
2839!^ & cff*(tl_vrhs(i,j )+ &
2840# ifdef WEC_MELLOR
2841!^ & tl_vbar_stokes(i,j )+ &
2842!^ & tl_vbar_stokes(i,j+1)+ &
2843# endif
2844!^ & tl_vrhs(i,j+1))
2845!^
2846 adfac=cff*ad_ufx(i,j)
2847 ad_vrhs(i,j )=ad_vrhs(i,j )+adfac
2848 ad_vrhs(i,j+1)=ad_vrhs(i,j+1)+adfac
2849# ifdef WEC_MELLOR
2850 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac
2851 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac
2852# endif
2853 ad_cff=ad_cff+ &
2854 & (vrhs(i,j )+ &
2855# ifdef WEC_MELLOR
2856 & vbar_stokes(i,j )+ &
2857 & vbar_stokes(i,j+1)+ &
2858# endif
2859 & vrhs(i,j+1))*ad_ufx(i,j)
2860 ad_ufx(i,j)=0.0_r8
2861!^ tl_cff=0.5_r8*tl_Drhs(i,j)*fomn(i,j)
2862!^
2863 ad_drhs(i,j)=ad_drhs(i,j)+0.5_r8*fomn(i,j)*ad_cff
2864 ad_cff=0.0_r8
2865 END DO
2866 END DO
2867#endif
2868
2869#if defined UV_ADV && !defined SOLVE3D
2870!
2871!-----------------------------------------------------------------------
2872! Adjoint of add in horizontal advection of momentum.
2873!-----------------------------------------------------------------------
2874!
2875! Add advection to RHS terms.
2876!
2877 DO j=jstr,jend
2878 DO i=istr,iend
2879 IF (j.ge.jstrv) THEN
2880# if defined DIAGNOSTICS_UV
2881!! DiaV2rhs(i,j,M2xadv)=-cff3
2882!! DiaV2rhs(i,j,M2yadv)=-cff4
2883!! DiaV2rhs(i,j,M2hadv)=-fac2
2884# endif
2885!^ tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
2886!^
2887 ad_fac2=ad_fac2-ad_rvbar(i,j)
2888!^ tl_fac2=tl_cff3+tl_cff4
2889!^
2890 ad_cff3=ad_cff3+ad_fac2
2891 ad_cff4=ad_cff4+ad_fac2
2892 ad_fac2=0.0_r8
2893!^ tl_cff4=tl_VFe(i,j)-tl_VFe(i,j-1)
2894!^
2895 ad_vfe(i,j-1)=ad_vfe(i,j-1)-ad_cff4
2896 ad_vfe(i,j )=ad_vfe(i,j )+ad_cff4
2897 ad_cff4=0.0_r8
2898!^ tl_cff3=tl_VFx(i+1,j)-tl_VFx(i,j)
2899!^
2900 ad_vfx(i ,j)=ad_vfx(i ,j)-ad_cff3
2901 ad_vfx(i+1,j)=ad_vfx(i+1,j)+ad_cff3
2902 ad_cff3=0.0_r8
2903 END IF
2904!
2905 IF (i.ge.istru) THEN
2906# if defined DIAGNOSTICS_UV
2907!! DiaU2rhs(i,j,M2xadv)=-cff1
2908!! DiaU2rhs(i,j,M2yadv)=-cff2
2909!! DiaU2rhs(i,j,M2hadv)=-fac1
2910# endif
2911!^ tl_rubar(i,j)=tl_rubar(i,j)-tl_fac1
2912!^
2913 ad_fac1=ad_fac1-ad_rubar(i,j)
2914!^ tl_fac1=tl_cff1+tl_cff2
2915!^
2916 ad_cff1=ad_cff1+ad_fac1
2917 ad_cff2=ad_cff2+ad_fac1
2918 ad_fac1=0.0_r8
2919!^ tl_cff2=tl_UFe(i,j+1)-tl_UFe(i,j)
2920!^
2921 ad_ufe(i,j )=ad_ufe(i,j )-ad_cff2
2922 ad_ufe(i,j+1)=ad_ufe(i,j+1)+ad_cff2
2923 ad_cff2=0.0_r8
2924!^ tl_cff1=tl_UFx(i,j)-tl_UFx(i-1,j)
2925!^
2926 ad_ufx(i-1,j)=ad_ufx(i-1,j)-ad_cff1
2927 ad_ufx(i ,j)=ad_ufx(i ,j)+ad_cff1
2928 ad_cff1=0.0_r8
2929 END IF
2930 END DO
2931 END DO
2932
2933# ifdef UV_C2ADVECTION
2934!
2935! Second-order, centered differences advection fluxes.
2936!
2937 DO j=jstr-1,jend
2938 DO i=istr,iend
2939!^ tl_UFe(i,j+1)=0.25_r8* &
2940# ifdef MASKING
2941!^ & pmask(i,j+1)* &
2942# endif
2943!^ & ((tl_DVom(i,j+1)+tl_DVom(i-1,j+1))* &
2944!^ & (urhs(i,j+1)+ &
2945# ifdef WEC_MELLOR
2946!^ & ubar_stokes(i,j+1)+ &
2947!^ & ubar_stokes(i,j )+ &
2948# endif
2949!^ & urhs(i,j ))+ &
2950!^ & (DVom(i,j+1)+DVom(i-1,j+1))* &
2951!^ & (tl_urhs(i,j+1)+ &
2952# ifdef WEC_MELLOR
2953!^ & tl_ubar_stokes(i,j+1)+ &
2954!^ & tl_ubar_stokes(i,j )+ &
2955# endif
2956!^ & tl_urhs(i,j )))
2957!^
2958 adfac=0.25_r8*ad_ufe(i,j+1)
2959 adfac1=adfac*(urhs(i,j+1)+ &
2960# ifdef WEC_MELLOR
2961 & ubar_stokes(i,j+1)+ &
2962 & ubar_stokes(i,j )+ &
2963# endif
2964 & urhs(i,j ))
2965 adfac2=adfac*(dvom(i,j+1)+dvom(i-1,j+1))
2966 ad_dvom(i-1,j+1)=ad_dvom(i-1,j+1)+adfac1
2967 ad_dvom(i ,j+1)=ad_dvom(i,j+1)+adfac1
2968 ad_urhs(i,j )=ad_urhs(i,j )+adfac2
2969 ad_urhs(i,j+1)=ad_urhs(i,j+1)+adfac2
2970# ifdef WEC_MELLOR
2971 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac2
2972 ad_ubar_stokes(i,j+1)=ad_ubar_stokes(i,j+1)+adfac2
2973# endif
2974 ad_ufe(i,j+1)=0.0_r8
2975!
2976 IF (j.ge.jstrv-1) THEN
2977!^ tl_VFe(i,j)=0.25_r8* &
2978!^ & ((tl_DVom(i,j)+tl_DVom(i,j+1))* &
2979!^ & (vrhs(i,j )+ &
2980# ifdef WEC_MELLOR
2981!^ & vbar_stokes(i,j )+ &
2982!^ & vbar_stokes(i,j+1)+ &
2983# endif
2984!^ & vrhs(i,j+1))+ &
2985!^ & (DVom(i,j)+DVom(i,j+1))* &
2986!^ & (tl_vrhs(i,j )+ &
2987# ifdef WEC_MELLOR
2988!^ & tl_vbar_stokes(i,j )+ &
2989!^ & tl_vbar_stokes(i,j+1)+ &
2990# endif
2991!^ & tl_vrhs(i,j+1)))
2992!^
2993 adfac=0.25_r8*ad_vfe(i,j)
2994 adfac1=adfac*(vrhs(i,j )+ &
2995# ifdef WEC_MELLOR
2996 & vbar_stokes(i,j )+ &
2997 & vbar_stokes(i,j+1)+ &
2998# endif
2999 & vrhs(i,j+1))
3000 adfac2=adfac*(dvom(i,j)+dvom(i,j+1))
3001 ad_dvom(i,j )=ad_dvom(i,j )+adfac1
3002 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac1
3003 ad_vrhs(i,j )=ad_vrhs(i,j )+adfac2
3004 ad_vrhs(i,j+1)=ad_vrhs(i,j+1)+adfac2
3005# ifdef WEC_MELLOR
3006 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac2
3007 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac2
3008# endif
3009 ad_vfe(i,j)=0.0_r8
3010 END IF
3011 END DO
3012 END DO
3013!
3014 DO j=jstr,jend
3015 DO i=istr-1,iend
3016!^ tl_VFx(i+1,j)=0.25_r8* &
3017# ifdef MASKING
3018!^ & pmask(i+1,j)* &
3019# endif
3020!^ & ((tl_DUon(i+1,j)+tl_DUon(i+1,j-1))* &
3021!^ & (vrhs(i+1,j)+ &
3022# ifdef WEC_MELLOR
3023!^ & vbar_stokes(i ,j)+ &
3024!^ & vbar_stokes(i-1,j)+ &
3025# endif
3026!^ & vrhs(i ,j))+ &
3027!^ & (DUon(i+1,j)+DUon(i+1,j-1))* &
3028!^ & (tl_vrhs(i+1,j)+ &
3029# ifdef WEC_MELLOR
3030!^ & tl_vbar_stokes(i ,j)+ &
3031!^ & tl_vbar_stokes(i-1,j)+ &
3032# endif
3033!^ & tl_vrhs(i ,j)))
3034!^
3035 adfac=0.25_r8* &
3036# ifdef MASKING
3037 & pmask(i+1,j)* &
3038# endif
3039 & ad_vfx(i+1,j)
3040 adfac1=adfac*(vrhs(i+1,j)+ &
3041# ifdef WEC_MELLOR
3042 & vbar_stokes(i ,j)+ &
3043 & vbar_stokes(i-1,j)+ &
3044# endif
3045 & vrhs(i ,j))
3046 adfac2=adfac*(duon(i+1,j)+duon(i+1,j-1))
3047 ad_duon(i+1,j-1)=ad_duon(i+1,j-1)+adfac1
3048 ad_duon(i+1,j )=ad_duon(i+1,j )+adfac1
3049 ad_vrhs(i ,j)=ad_vrhs(i ,j)+adfac2
3050 ad_vrhs(i+1,j)=ad_vrhs(i+1,j)+adfac2
3051# ifdef WEC_MELLOR
3052 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac2
3053 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac2
3054# endif
3055 ad_vfx(i+1,j)=0.0_r8
3056!
3057 IF (i.ge.istru-1) THEN
3058!^ tl_UFx(i,j)=0.25_r8* &
3059!^ & ((tl_DUon(i,j)+tl_DUon(i+1,j))* &
3060!^ & (urhs(i ,j)+ &
3061# ifdef WEC_MELLOR
3062!^ & ubar_stokes(i ,j)+ &
3063!^ & ubar_stokes(i+1,j)+ &
3064# endif
3065!^ & urhs(i+1,j))+ &
3066!^ & (DUon(i,j)+DUon(i+1,j))* &
3067!^ & (tl_urhs(i ,j)+ &
3068# ifdef WEC_MELLOR
3069!^ & tl_ubar_stokes(i ,j)+ &
3070!^ & tl_ubar_stokes(i+1,j)+ &
3071# endif
3072!^ & tl_urhs(i+1,j)))
3073!^
3074 adfac=0.25_r8*ad_ufx(i,j
3075 adfac1=adfac*(urhs(i ,j)+ &
3076# ifdef WEC_MELLOR
3077 & ubar_stokes(i ,j)+ &
3078 & ubar_stokes(i+1,j)+ &
3079# endif
3080 & urhs(i+1,j))
3081 adfac2=adfac*(duon(i,j)+duon(i+1,j))
3082 ad_duon(i ,j)=ad_duon(i ,j)+adfac1
3083 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac1
3084 ad_urhs(i ,j)=ad_urhs(i ,j)+adfac2
3085 ad_urhs(i+1,j)=ad_urhs(i+1,j)+adfac2
3086# ifdef WEC_MELLOR
3087 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac2
3088 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac2
3089# endif
3090 ad_ufx(i,j)=0.0_r8
3091 END IF
3092 END DO
3093 END DO
3094!
3095
3096# elif defined UV_C4ADVECTION
3097!
3098! Fourth-order, centered differences v-momentum advection fluxes.
3099!
3100 DO j=jstrvm1,jendp1 ! BASIC STATE
3101 DO i=istr,iend
3102 grad(i,j)=vrhs(i,j-1)-2.0_r8*vrhs(i,j)+ &
3103# ifdef WEC_MELLOR
3104 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
3105 & vbar_stokes(i,j+1)+ &
3106# endif
3107 & vrhs(i,j+1)
3108 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
3109 END DO
3110 END DO
3111 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3112 IF (domain(ng)%Northern_Edge(tile)) THEN
3113 DO i=istr,iend
3114 grad(i,jend+1)=grad(i,jend)
3115 dgrad(i,jend+1)=dgrad(i,jend)
3116 END DO
3117 END IF
3118 END IF
3119 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3120 IF (domain(ng)%Southern_Edge(tile)) THEN
3121 DO i=istr,iend
3122 grad(i,jstr)=grad(i,jstr+1)
3123 dgrad(i,jstr)=dgrad(i,jstr+1)
3124 END DO
3125 END IF
3126 END IF
3127! d/dy(Dvv/m)
3128 cff=1.0_r8/6.0_r8
3129 DO j=jstrv-1,jend
3130 DO i=istr,iend
3131!^ tl_VFe(i,j)=0.25_r8* &
3132!^ & ((tl_vrhs(i,j )+ &
3133# ifdef WEC_MELLOR
3134!^ & tl_vbar_stokes(i,j )+ &
3135!^ & tl_vbar_stokes(i,j+1)+ &
3136# endif
3137!^ & tl_vrhs(i,j+1)- &
3138!^ & cff*(tl_grad (i,j)+tl_grad (i,j+1)))* &
3139!^ & (DVom(i,j)+DVom(i,j+1)- &
3140!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))+ &
3141!^ & (vrhs(i,j )+ &
3142# ifdef WEC_MELLOR
3143!^ & vbar_stokes(i,j )+ &
3144!^ & vbar_stokes(i,j+1)+ &
3145# endif
3146!^ & vrhs(i,j+1)- &
3147!^ & cff*(grad (i,j)+grad (i,j+1)))* &
3148!^ & (tl_DVom(i,j)+tl_DVom(i,j+1)- &
3149!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j+1))))
3150!^
3151 adfac=0.25_r8*ad_vfe(i,j)
3152 adfac1=adfac*(dvom(i,j)+dvom(i,j+1)- &
3153 & cff*(dgrad(i,j)+dgrad(i,j+1)))
3154 adfac2=adfac1*cff
3155 adfac3=adfac*(vrhs(i,j )+ &
3156# ifdef WEC_MELLOR
3157 & vbar_stokes(i,j )+ &
3158 & vbar_stokes(i,j+1)+ &
3159# endif
3160 & vrhs(i,j+1,krhs)- &
3161 & cff*(grad(i,j)+grad(i,j+1)))
3162 adfac4=adfac3*cff
3163 ad_vrhs(i,j )=ad_vrhs(i,j )+adfac1
3164 ad_vrhs(i,j+1)=ad_vrhs(i,j+1)+adfac1
3165# ifdef WEC_MELLOR
3166 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )+adfac1
3167 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+adfac1
3168# endif
3169 ad_grad(i,j )=ad_grad(i,j )-adfac2
3170 ad_grad(i,j+1)=ad_grad(i,j+1)-adfac2
3171 ad_dvom(i,j )=ad_dvom(i,j )+adfac3
3172 ad_dvom(i,j+1)=ad_dvom(i,j+1)+adfac3
3173 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3174 ad_dgrad(i,j+1)=ad_dgrad(i,j+1)-adfac4
3175 ad_vfe(i,j)=0.0_r8
3176 END DO
3177 END DO
3178!
3179 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3180 IF (domain(ng)%Northern_Edge(tile)) THEN
3181 DO i=istr,iend
3182!^ tl_Dgrad(i,Jend+1)=tl_Dgrad(i,Jend)
3183!^
3184 ad_dgrad(i,jend)=ad_dgrad(i,jend)+ad_dgrad(i,jend+1)
3185 ad_dgrad(i,jend+1)=0.0_r8
3186!^ tl_grad (i,Jend+1)=tl_grad (i,Jend)
3187!^
3188 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3189 ad_grad(i,jend+1)=0.0_r8
3190 END DO
3191 END IF
3192 END IF
3193 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3194 IF (domain(ng)%Southern_Edge(tile)) THEN
3195 DO i=istr,iend
3196!^ tl_Dgrad(i,Jstr)=tl_Dgrad(i,Jstr+1)
3197!^
3198 ad_dgrad(i,jstr+1)=ad_dgrad(i,jstr+1)+ad_dgrad(i,jstr)
3199 ad_dgrad(i,jstr)=0.0_r8
3200!^ tl_grad (i,Jstr)=tl_grad (i,Jstr+1)
3201!^
3202 ad_grad(i,jstr+1)=ad_grad(i,jstr+1)+ad_grad(i,jstr)
3203 ad_grad(i,jstr)=0.0_r8
3204 END DO
3205 END IF
3206 END IF
3207 DO j=jstrvm1,jendp1
3208 DO i=istr,iend
3209!^ tl_Dgrad(i,j)=tl_DVom(i,j-1)-2.0_r8*tl_DVom(i,j)+ &
3210!^ & tl_DVom(i,j+1)
3211!^
3212 ad_dvom(i,j-1)=ad_dvom(i,j-1)+ad_dgrad(i,j)
3213 ad_dvom(i,j )=ad_dvom(i,j )-2.0_r8*ad_dgrad(i,j)
3214 ad_dvom(i,j+1)=ad_dvom(i,j+1)+ad_dgrad(i,j)
3215 ad_dgrad(i,j)=0.0_r8
3216!^ tl_grad(i,j)=tl_vrhs(i,j-1)-2.0_r8*tl_vrhs(i,j)+ &
3217!^
3218# ifdef WEC_MELLOR
3219!^ & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
3220!^ & tl_vbar_stokes(i,j+1)+ &
3221# endif
3222!^ & tl_vrhs(i,j+1)
3223!^
3224 ad_vrhs(i,j-1)=ad_vrhs(i,j-1)+ad_grad(i,j)
3225 ad_vrhs(i,j )=ad_vrhs(i,j )-2.0_r8*ad_grad(i,j)
3226 ad_vrhs(i,j+1)=ad_vrhs(i,j+1)+ad_grad(i,j)
3227# ifdef WEC_MELLOR
3228 ad_vbar_stokes(i,j-1)=ad_vbar_stokes(i,j-1)+ad_grad(i,j)
3229 ad_vbar_stokes(i,j )=ad_vbar_stokes(i,j )- &
3230 & 2.0_r8*ad_grad(i,j)
3231 ad_vbar_stokes(i,j+1)=ad_vbar_stokes(i,j+1)+ad_grad(i,j)
3232# endif
3233 ad_grad(i,j)=0.0_r8
3234 END DO
3235 END DO
3236!
3237 DO j=jstrv,jend ! BASIC STATE
3238 DO i=istrm1,iendp1
3239 grad(i,j)=vrhs(i-1,j)-2.0_r8*vrhs(i,j,krhs)+ &
3240# ifdef WEC_MELLOR
3241 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
3242 & vbar_stokes(i+1,j)+ &
3243# endif
3244 & vrhs(i+1,j)
3245 END DO
3246 END DO
3247 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3248 IF (domain(ng)%Western_Edge(tile)) THEN
3249 DO j=jstrv,jend
3250 grad(istr-1,j)=grad(istr,j)
3251 END DO
3252 END IF
3253 END IF
3254 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3255 IF (domain(ng)%Eastern_Edge(tile)) THEN
3256 DO j=jstrv,jend
3257 grad(iend+1,j)=grad(iend,j)
3258 END DO
3259 END IF
3260 END IF
3261 DO j=jstrv-1,jend
3262 DO i=istr,iend+1
3263 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
3264 END DO
3265 END DO
3266! d/dx(Duv/n)
3267 cff=1.0_r8/6.0_r8
3268 DO j=jstrv,jend
3269 DO i=istr,iend+1
3270!^ tl_VFx(i,j)=0.25_r8* &
3271!^ & ((tl_vrhs(i ,j)+ &
3272# ifdef WEC_MELLOR
3273!^ & tl_vbar_stokes(i ,j)+ &
3274!^ & tl_vbar_stokes(i-1,j)+ &
3275# endif
3276!^ & tl_vrhs(i-1,j)- &
3277!^ & cff*(tl_grad (i,j)+tl_grad (i-1,j)))* &
3278!^ & (DUon(i,j)+DUon(i,j-1)- &
3279!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))+ &
3280!^ & (vrhs(i ,j)+ &
3281# ifdef WEC_MELLOR
3282!^ & vbar_stokes(i ,j)+ &
3283!^ & vbar_stokes(i-1,j)+ &
3284# endif
3285!^ & vrhs(i-1,j)- &
3286!^ & cff*(grad (i,j)+grad (i-1,j)))* &
3287!^ & (tl_DUon(i,j)+tl_DUon(i,j-1)- &
3288!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i,j-1))))
3289!^
3290 adfac=0.25_r8*ad_vfx(i,j)
3291 adfac1=adfac*(duon(i,j)+duon(i,j-1)- &
3292 & cff*(dgrad(i,j)+dgrad(i,j-1)))
3293 adfac2=adfac1*cff
3294 adfac3=adfac*(vrhs(i ,j)+ &
3295# ifdef WEC_MELLOR
3296 & vbar_stokes(i ,j)+ &
3297 & vbar_stokes(i-1,j)+ &
3298# endif
3299 & vrhs(i-1,j)- &
3300 & cff*(grad(i,j)+grad(i-1,j)))
3301 adfac4=adfac3*cff
3302 ad_vrhs(i-1,j)=ad_vrhs(i-1,j)+adfac1
3303 ad_vrhs(i ,j)=ad_vrhs(i ,j)+adfac1
3304# ifdef WEC_MELLOR
3305 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+adfac1
3306 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)+adfac1
3307# endif
3308 ad_grad(i-1,j)=ad_grad(i-1,j)-adfac2
3309 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
3310 ad_duon(i,j-1)=ad_duon(i,j-1)+adfac3
3311 ad_duon(i,j )=ad_duon(i,j )+adfac3
3312 ad_dgrad(i,j-1)=ad_dgrad(i,j-1)-adfac4
3313 ad_dgrad(i,j )=ad_dgrad(i,j )-adfac4
3314 ad_vfx(i,j)=0.0_r8
3315 END DO
3316 END DO
3317!
3318 DO j=jstrv-1,jend
3319 DO i=istr,iend+1
3320!^ tl_Dgrad(i,j)=tl_DUon(i,j-1)-2.0_r8*tl_DUon(i,j)+ &
3321!^ & tl_DUon(i,j+1)
3322!^
3323 ad_duon(i,j-1)=ad_duon(i,j-1)+ad_dgrad(i,j)
3324 ad_duon(i,j )=ad_duon(i,j )-2.0_r8*ad_dgrad(i,j)
3325 ad_duon(i,j+1)=ad_duon(i,j+1)+ad_dgrad(i,j)
3326 ad_dgrad(i,j)=0.0_r8
3327 END DO
3328 END DO
3329 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3330 IF (domain(ng)%Eastern_Edge(tile)) THEN
3331 DO j=jstrv,jend
3332!^ tl_grad(Iend+1,j)=tl_grad(Iend,j)
3333!^
3334 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
3335 ad_grad(iend+1,j)=0.0_r8
3336 END DO
3337 END IF
3338 END IF
3339 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3340 IF (domain(ng)%Western_Edge(tile)) THEN
3341 DO j=jstrv,jend
3342!^ tl_grad(Istr-1,j)=tl_grad(Istr,j)
3343!^
3344 ad_grad(istr,j)=ad_grad(istr,j)+ad_grad(istr-1,j)
3345 ad_grad(istr-1,j)=0.0_r8
3346 END DO
3347 END IF
3348 END IF
3349 DO j=jstrv,jend
3350 DO i=istrm1,iendp1
3351!^ tl_grad(i,j)=tl_vrhs(i-1,j)-2.0_r8*tl_vrhs(i,j)+ &
3352# ifdef WEC_MELLOR
3353!^ & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
3354!^ & tl_vbar_stokes(i+1,j)+ &
3355# endif
3356!^ & tl_vrhs(i+1,j)
3357!^
3358 ad_vrhs(i-1,j)=ad_vrhs(i-1,j)+ad_grad(i,j)
3359 ad_vrhs(i ,j)=ad_vrhs(i ,j)-2.0_r8*ad_grad(i,j)
3360 ad_vrhs(i+1,j)=ad_vrhs(i+1,j)+ad_grad(i,j)
3361# ifdef WEC_MELLOR
3362 ad_vbar_stokes(i-1,j)=ad_vbar_stokes(i-1,j)+ad_grad(i,j)
3363 ad_vbar_stokes(i ,j)=ad_vbar_stokes(i ,j)- &
3364 & 2.0_r8*ad_grad(i,j)
3365 ad_vbar_stokes(i+1,j)=ad_vbar_stokes(i+1,j)+ad_grad(i,j)
3366# endif
3367 ad_grad(i,j)=0.0_r8
3368 END DO
3369 END DO
3370!
3371! Fourth-order, centered differences u-momentum advection fluxes.
3372!
3373 DO j=jstrm1,jendp1 ! BASIC STATE
3374 DO i=istru,iend
3375 grad(i,j)=urhs(i,j-1)-2.0_r8*urhs(i,j)+ &
3376# ifdef WEC_MELLOR
3377 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
3378 & ubar_stokes(i,j+1)+ &
3379# endif
3380 & urhs(i,j+1)
3381 END DO
3382 END DO
3383 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3384 IF (domain(ng)%Southern_Edge(tile)) THEN
3385 DO i=istru,iend
3386 grad(i,jstr-1)=grad(i,jstr)
3387 END DO
3388 END IF
3389 END IF
3390 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3391 IF (domain(ng)%Northern_Edge(tile)) THEN
3392 DO i=istru,iend
3393 grad(i,jend+1)=grad(i,jend)
3394 END DO
3395 END IF
3396 END IF
3397 DO j=jstr,jend+1
3398 DO i=istru-1,iend
3399 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
3400 END DO
3401 END DO
3402! d/dy(Duv/m)
3403 cff=1.0_r8/6.0_r8
3404 DO j=jstr,jend+1
3405 DO i=istru,iend
3406!^ tl_UFe(i,j)=0.25_r8* &
3407!^ & ((tl_urhs(i,j )+ &
3408# ifdef WEC_MELLOR
3409!^ & tl_ubar_stokes(i,j )+ &
3410!^ & tl_ubar_stokes(i,j-1)+ &
3411# endif
3412!^ & tl_urhs(i,j-1)- &
3413!^ & cff*(tl_grad (i,j)+tl_grad (i,j-1)))* &
3414!^ & (DVom(i,j)+DVom(i-1,j)- &
3415!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))+ &
3416!^ & (urhs(i,j )+ &
3417# ifdef WEC_MELLOR
3418!^ & ubar_stokes(i,j )+ &
3419!^ & ubar_stokes(i,j-1)+ &
3420# endif
3421!^ & urhs(i,j-1)- &
3422!^ & cff*(grad (i,j)+grad (i,j-1)))* &
3423!^ & (tl_DVom(i,j)+tl_DVom(i-1,j)- &
3424!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i-1,j))))
3425!^
3426 adfac=0.25_r8*ad_ufe(i,j)
3427 adfac1=adfac*(dvom(i,j)+dvom(i-1,j)- &
3428 & cff*(dgrad(i,j)+dgrad(i-1,j)))
3429 adfac2=adfac1*cff
3430 adfac3=adfac*(urhs(i,j )+ &
3431# ifdef WEC_MELLOR
3432 & ubar_stokes(i,j )+ &
3433 & ubar_stokes(i,j-1)+ &
3434# endif
3435 & urhs(i,j-1,krhs)- &
3436 & cff*(grad(i,j)+grad(i,j-1)))
3437 adfac4=adfac3*cff
3438 ad_urhs(i,j-1)=ad_urhs(i,j-1)+adfac1
3439 ad_urhs(i,j )=ad_urhs(i,j )+adfac1
3440# ifdef WEC_MELLOR
3441 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+adfac1
3442 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j )+adfac1
3443# endif
3444 ad_grad(i,j-1)=ad_grad(i,j-1)-adfac2
3445 ad_grad(i,j )=ad_grad(i,j )-adfac2
3446 ad_dvom(i-1,j)=ad_dvom(i-1,j)+adfac3
3447 ad_dvom(i ,j)=ad_dvom(i ,j)+adfac3
3448 ad_dgrad(i-1,j)=ad_dgrad(i-1,j)-adfac4
3449 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
3450 ad_ufe(i,j)=0.0_r8
3451 END DO
3452 END DO
3453!
3454 DO j=jstr,jend+1
3455 DO i=istru-1,iend
3456!^ tl_Dgrad(i,j)=tl_DVom(i-1,j)-2.0_r8*tl_DVom(i,j)+ &
3457!^ & tl_DVom(i+1,j)
3458!^
3459 ad_dvom(i-1,j)=ad_dvom(i-1,j)+ad_dgrad(i,j)
3460 ad_dvom(i ,j)=ad_dvom(i ,j)-2.0_r8*ad_dgrad(i,j)
3461 ad_dvom(i+1,j)=ad_dvom(i+1,j)+ad_dgrad(i,j)
3462 ad_dgrad(i,j)=0.0_r8
3463 END DO
3464 END DO
3465 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3466 IF (domain(ng)%Northern_Edge(tile)) THEN
3467 DO i=istru,iend
3468!^ tl_grad(i,Jend+1)=tl_grad(i,Jend)
3469!^
3470 ad_grad(i,jend)=ad_grad(i,jend)+ad_grad(i,jend+1)
3471 ad_grad(i,jend+1)=0.0_r8
3472 END DO
3473 END IF
3474 END IF
3475 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3476 IF (domain(ng)%Southern_Edge(tile)) THEN
3477 DO i=istru,iend
3478!^ tl_grad(i,Jstr-1)=tl_grad(i,Jstr)
3479!^
3480 ad_grad(i,jstr)=ad_grad(i,jstr)+ad_grad(i,jstr-1)
3481 ad_grad(i,jstr-1)=0.0_r8
3482 END DO
3483 END IF
3484 END IF
3485 DO j=jstrm1,jendp1
3486 DO i=istru,iend
3487!^ tl_grad(i,j)=tl_urhs(i,j-1)-2.0_r8*tl_urhs(i,j)+ &
3488# ifdef WEC_MELLOR
3489!^ & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
3490!^ & tl_ubar_stokes(i,j+1)+ &
3491# endif
3492!^ & tl_urhs(i,j+1)
3493!^
3494 ad_urhs(i,j-1)=ad_urhs(i,j-1)+ad_grad(i,j)
3495 ad_urhs(i,j )=ad_urhs(i,j )-2.0_r8*ad_grad(i,j)
3496 ad_urhs(i,j+1)=ad_urhs(i,j+1)+ad_grad(i,j)
3497# ifdef WEC_MELLOR
3498 ad_ubar_stokes(i,j-1)=ad_ubar_stokes(i,j-1)+ad_grad(i,j)
3499 ad_ubar_stokes(i,j )=ad_ubar_stokes(i,j)- &
3500 & 2.0_r8*ad_grad(i,j)
3501 ad_ubar_stokes(i,j+1)=ad_ubar_stokes(i,j+1)+ad_grad(i,j)
3502# endif
3503 ad_grad(i,j)=0.0_r8
3504 END DO
3505 END DO
3506!
3507 DO j=jstr,jend ! BASIC STATE
3508 DO i=istrum1,iendp1
3509 grad(i,j)=urhs(i-1,j)-2.0_r8*urhs(i,j)+ &
3510# ifdef WEC_MELLOR
3511 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
3512 & ubar_stokes(i+1,j)+ &
3513# endif
3514 & urhs(i+1,j,krhs)
3515 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
3516 END DO
3517 END DO
3518 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3519 IF (domain(ng)%Western_Edge(tile)) THEN
3520 DO j=jstr,jend
3521 grad(istr,j)=grad(istr+1,j)
3522 dgrad(istr,j)=dgrad(istr+1,j)
3523 END DO
3524 END IF
3525 END IF
3526 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3527 IF (domain(ng)%Eastern_Edge(tile)) THEN
3528 DO j=jstr,jend
3529 grad(iend+1,j)=grad(iend,j)
3530 dgrad(iend+1,j)=dgrad(iend,j)
3531 END DO
3532 END IF
3533 END IF
3534! d/dx(Duu/n)
3535 cff=1.0_r8/6.0_r8
3536 DO j=jstr,jend
3537 DO i=istru-1,iend
3538!^ tl_UFx(i,j)=0.25_r8* &
3539!^ & ((urhs(i ,j)+ &
3540# ifdef WEC_MELLOR
3541!^ & ubar_stokes(i ,j)+ &
3542!^ & ubar_stokes(i+1,j)+ &
3543# endif
3544!^ & urhs(i+1,j)- &
3545!^ & cff*(grad (i,j)+grad (i+1,j)))* &
3546!^ & (tl_DUon(i,j)+tl_DUon(i+1,j)- &
3547!^ & cff*(tl_Dgrad(i,j)+tl_Dgrad(i+1,j)))+ &
3548!^ & (tl_urhs(i ,j)+ &
3549# ifdef WEC_MELLOR
3550!^ & tl_ubar_stokes(i ,j)+ &
3551!^ & tl_ubar_stokes(i+1,j)+ &
3552# endif
3553!^ & tl_urhs(i+1,j)- &
3554!^ & cff*(tl_grad (i,j)+tl_grad (i+1,j)))* &
3555!^ & (DUon(i,j)+DUon(i+1,j)- &
3556!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j))))
3557!^
3558 adfac=0.25_r8*ad_ufx(i,j)
3559 adfac1=adfac*(duon(i,j)+duon(i+1,j)- &
3560 & cff*(dgrad(i,j)+dgrad(i+1,j)))
3561 adfac2=adfac1*cff
3562 adfac3=adfac*(urhs(i ,j)+ &
3563# ifdef WEC_MELLOR
3564 & ubar_stokes(i ,j)+ &
3565 & ubar_stokes(i+1,j)+ &
3566# endif
3567 & urhs(i+1,j)- &
3568 & cff*(grad(i,j)+grad(i+1,j)))
3569 adfac4=adfac3*cff
3570 ad_urhs(i ,j)=ad_urhs(i ,j)+adfac1
3571 ad_urhs(i+1,j)=ad_urhs(i+1,j)+adfac1
3572# ifdef WEC_MELLOR
3573 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)+adfac1
3574 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+adfac1
3575# endif
3576 ad_grad(i ,j)=ad_grad(i ,j)-adfac2
3577 ad_grad(i+1,j)=ad_grad(i+1,j)-adfac2
3578 ad_duon(i ,j)=ad_duon(i ,j)+adfac3
3579 ad_duon(i+1,j)=ad_duon(i+1,j)+adfac3
3580 ad_dgrad(i ,j)=ad_dgrad(i ,j)-adfac4
3581 ad_dgrad(i+1,j)=ad_dgrad(i+1,j)-adfac4
3582 ad_ufx(i,j)=0.0_r8
3583 END DO
3584 END DO
3585!
3586 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3587 IF (domain(ng)%Eastern_Edge(tile)) THEN
3588 DO j=jstr,jend
3589!^ tl_Dgrad(Iend+1,j)=tl_Dgrad(Iend,j)
3590!^
3591 ad_dgrad(iend,j)=ad_dgrad(iend,j)+ad_dgrad(iend+1,j)
3592 ad_dgrad(iend+1,j)=0.0_r8
3593!^ tl_grad (Iend+1,j)=tl_grad (Iend,j)
3594!^
3595 ad_grad(iend,j)=ad_grad(iend,j)+ad_grad(iend+1,j)
3596 ad_grad(iend+1,j)=0.0_r8
3597 END DO
3598 END IF
3599 END IF
3600 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3601 IF (domain(ng)%Western_Edge(tile)) THEN
3602 DO j=jstr,jend
3603!^ tl_Dgrad(Istr,j)=tl_Dgrad(Istr+1,j)
3604!^
3605 ad_dgrad(istr+1,j)=ad_dgrad(istr+1,j)+ad_dgrad(istr,j)
3606 ad_dgrad(istr,j)=0.0_r8
3607!^ tl_grad (Istr,j)=tl_grad (Istr+1,j)
3608!^
3609 ad_grad(istr+1,j)=ad_grad(istr+1,j)+ad_grad(istr,j)
3610 ad_grad(istr,j)=0.0_r8
3611 END DO
3612 END IF
3613 END IF
3614 DO j=jstr,jend
3615 DO i=istrum1,iendp1
3616!^ tl_Dgrad(i,j)=tl_DUon(i-1,j)-2.0_r8*tl_DUon(i,j)+ &
3617!^ & tl_DUon(i+1,j)
3618!^
3619 ad_duon(i-1,j)=ad_duon(i-1,j)+ad_dgrad(i,j)
3620 ad_duon(i ,j)=ad_duon(i ,j)-2.0_r8*ad_dgrad(i,j)
3621 ad_duon(i+1,j)=ad_duon(i+1,j)+ad_dgrad(i,j)
3622 ad_dgrad(i,j)=0.0_r8
3623!^ tl_grad(i,j)=tl_urhs(i-1,j)-2.0_r8*tl_urhs(i,j)+ &
3624# ifdef WEC_MELLOR
3625!^ & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
3626!^ & tl_ubar_stokes(i+1,j)+ &
3627# endif
3628!^ & tl_urhs(i+1,j)
3629!^
3630 ad_urhs(i-1,j)=ad_urhs(i-1,j)+ad_grad(i,j)
3631 ad_urhs(i ,j)=ad_urhs(i ,j)-2.0_r8*ad_grad(i,j)
3632 ad_urhs(i+1,j)=ad_urhs(i+1,j)+ad_grad(i,j)
3633# ifdef NEARHSORE_MELLOR
3634 ad_ubar_stokes(i-1,j)=ad_ubar_stokes(i-1,j)+ad_grad(i,j)
3635 ad_ubar_stokes(i ,j)=ad_ubar_stokes(i ,j)- &
3636 & 2.0_r8*ad_grad(i,j)
3637 ad_ubar_stokes(i+1,j)=ad_ubar_stokes(i+1,j)+ad_grad(i,j)
3638# endif
3639 ad_grad(i,j)=0.0_r8
3640 END DO
3641 END DO
3642# endif
3643#endif
3644!
3645!-----------------------------------------------------------------------
3646! Adjoint of compute pressure-gradient terms.
3647!-----------------------------------------------------------------------
3648!
3649 cff1=0.5_r8*g
3650#if defined VAR_RHO_2D && defined SOLVE3D
3651 cff2=0.333333333333_r8
3652#endif
3653#if defined ATM_PRESS && !defined SOLVE3D
3654 cff3=0.5_r8*100.0_r8/rho0
3655#endif
3656 DO j=jstr,jend
3657 DO i=istr,iend
3658 IF (j.ge.jstrv) THEN
3659#ifdef DIAGNOSTICS_UV
3660!! DiaV2rhs(i,j,M2pgrd)=rvbar(i,j)
3661#endif
3662#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
3663!^ tl_rvbar(i,j)=tl_rvbar(i,j)- &
3664!^ & cff1*om_v(i,j)* &
3665!^ & ((tl_h(i,j-1)+tl_h(i,j)+ &
3666!^ & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
3667!^ & (eq_tide(i,j)-eq_tide(i,j-1))+ &
3668!^ & (h(i,j-1)+h(i,j)+ &
3669!^ & rzeta(i,j-1)+rzeta(i,j))* &
3670!^ & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
3671!^
3672 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
3673 adfac1=adfac*(eq_tide(i,j)-eq_tide(i,j-1))
3674 adfac2=adfac*(h(i,j-1)+h(i,j)+ &
3675 & rzeta(i,j-1)+rzeta(i,j))
3676 ad_h(i,j-1)=ad_h(i,j-1)-adfac1
3677 ad_h(i,j )=ad_h(i,j )-adfac1
3678 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)-adfac1
3679 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac1
3680 ad_eq_tide(i,j-1)=ad_eq_tide(i,j-1)+adfac2
3681 ad_eq_tide(i,j )=ad_eq_tide(i,j )-adfac2
3682#endif
3683#if defined ATM_PRESS && !defined SOLVE3D
3684!^ tl_rvbar(i,j)=tl_rvbar(i,j)- &
3685!^ & cff3*om_v(i,j)* &
3686!^ & (tl_h(i,j-1)+tl_h(i,j)+ &
3687!^ & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
3688!^ & (Pair(i,j)-Pair(i,j-1))
3689!^
3690 adfac=-cff3*om_v(i,j)*(pair(i,j)-pair(i,j-1)*ad_rvbar(i,j)
3691 ad_h(i,j-1)=ad_h(i,j-1)+adfac
3692 ad_h(i,j )=ad_h(i,j )+adfac
3693 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac
3694 ad_rzeta(i,j )=ad_rzeta(i,j )+adfac
3695#endif
3696!^ tl_rvbar(i,j)=cff1*om_v(i,j)* &
3697!^ & ((tl_h(i,j-1)+ &
3698!^ & tl_h(i,j ))* &
3699!^ & (rzeta(i,j-1)- &
3700!^ & rzeta(i,j ))+ &
3701!^ & (h(i,j-1)+ &
3702!^ & h(i,j ))* &
3703!^ & (tl_rzeta(i,j-1)- &
3704!^ & tl_rzeta(i,j ))+ &
3705#if defined VAR_RHO_2D && defined SOLVE3D
3706!^ & (tl_h(i,j-1)- &
3707!^ & tl_h(i,j ))* &
3708!^ & (rzetaSA(i,j-1)+ &
3709!^ & rzetaSA(i,j )+ &
3710!^ & cff2*(rhoA(i,j-1)- &
3711!^ & rhoA(i,j ))* &
3712!^ & (zwrk(i,j-1)- &
3713!^ & zwrk(i,j )))+ &
3714!^ & (h(i,j-1)- &
3715!^ & h(i,j ))* &
3716!^ & (tl_rzetaSA(i,j-1)+ &
3717!^ & tl_rzetaSA(i,j )+ &
3718!^ & cff2*((tl_rhoA(i,j-1)- &
3719!^ & tl_rhoA(i,j ))* &
3720!^ & (zwrk(i,j-1)- &
3721!^ & zwrk(i,j ))+ &
3722!^ & (rhoA(i,j-1)- &
3723!^ & rhoA(i,j ))* &
3724!^ & (tl_zwrk(i,j-1)- &
3725!^ & tl_zwrk(i,j ))))+ &
3726#endif
3727!^ & (tl_rzeta2(i,j-1)- &
3728!^ & tl_rzeta2(i,j )))
3729!^
3730 adfac=cff1*om_v(i,j)*ad_rvbar(i,j)
3731 adfac1=adfac*(rzeta(i,j-1)-rzeta(i,j ))
3732 adfac2=adfac*(h(i,j-1)+h(i,j ))
3733 ad_h(i,j-1)=ad_h(i,j-1)+adfac1
3734 ad_h(i,j )=ad_h(i,j )+adfac1
3735 ad_rzeta(i,j-1)=ad_rzeta(i,j-1)+adfac2
3736 ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2
3737 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac
3738 ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac
3739#if defined VAR_RHO_2D && defined SOLVE3D
3740 adfac3=adfac*(rzetasa(i,j-1)+ &
3741 & rzetasa(i,j )+ &
3742 & cff2*(rhoa(i,j-1)- &
3743 & rhoa(i,j ))* &
3744 & (zwrk(i,j-1)- &
3745 & zwrk(i,j )))
3746 adfac4=adfac2*cff2*(zwrk(i,j-1)-zwrk(i,j))
3747 adfac5=adfac2*cff2*(rhoa(i,j-1)-rhoa(i,j))
3748 ad_h(i,j-1)=ad_h(i,j-1)+adfac3
3749 ad_h(i,j )=ad_h(i,j )-adfac3
3750 ad_rzetasa(i,j-1)=ad_rzetasa(i,j-1)+adfac2
3751 ad_rzetasa(i,j )=ad_rzetasa(i,j )+adfac2
3752 ad_rhoa(i,j-1)=ad_rhoa(i,j-1)+adfac4
3753 ad_rhoa(i,j )=ad_rhoa(i,j )-adfac4
3754 ad_zwrk(i,j-1)=ad_zwrk(i,j-1)+adfac5
3755 ad_zwrk(i,j )=ad_zwrk(i,j )-adfac5
3756#endif
3757 ad_rvbar(i,j)=0.0_r8
3758 END IF
3759!
3760 IF (i.ge.istru) THEN
3761#ifdef DIAGNOSTICS_UV
3762!! DiaU2rhs(i,j,M2pgrd)=rubar(i,j)
3763#endif
3764#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
3765!^ tl_rubar(i,j)=tl_rubar(i,j)- &
3766!^ & cff1*on_u(i,j)* &
3767!^ & ((tl_h(i-1,j)+tl_h(i,j)+ &
3768!^ & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
3769!^ & (eq_tide(i,j)-eq_tide(i-1,j))+ &
3770!^ & (h(i-1,j)+h(i,j)+ &
3771!^ & rzeta(i-1,j)+rzeta(i,j))* &
3772!^ & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
3773!^
3774 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
3775 adfac1=adfac*(eq_tide(i,j)-eq_tide(i-1,j))
3776 adfac2=adfac*(h(i-1,j)+h(i,j)+ &
3777 & rzeta(i-1,j)+rzeta(i,j))
3778 ad_h(i-1,j)=ad_h(i-1,j)-adfac1
3779 ad_h(i ,j)=ad_h(i ,j)-adfac1
3780 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)-adfac1
3781 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac1
3782 ad_eq_tide(i-1,j)=ad_eq_tide(i-1,j)+adfac2
3783 ad_eq_tide(i ,j)=ad_eq_tide(i ,j)-adfac2
3784#endif
3785#if defined ATM_PRESS && !defined SOLVE3D
3786!^ tl_rubar(i,j)=tl_rubar(i,j)- &
3787!^ & cff3*on_u(i,j)* &
3788!^ & (tl_h(i-1,j)+tl_h(i,j)+ &
3789!^ & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
3790!^ & (Pair(i,j)-Pair(i-1,j))
3791!^
3792 adfac=-cff3*on_u(i,j)*(pair(i,j)-pair(i-1,j))*ad_rubar(i,j)
3793 ad_h(i-1,j)=ad_h(i-1,j)+adfac
3794 ad_h(i ,j)=ad_h(i ,j)+adfac
3795 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac
3796 ad_rzeta(i ,j)=ad_rzeta(i ,j)+adfac
3797#endif
3798!^ tl_rubar(i,j)=cff1*on_u(i,j)* &
3799!^ & ((tl_h(i-1,j)+ &
3800!^ & tl_h(i ,j))* &
3801!^ & (rzeta(i-1,j)- &
3802!^ & rzeta(i ,j))+ &
3803!^ & (h(i-1,j)+ &
3804!^ & h(i ,j))* &
3805!^ & (tl_rzeta(i-1,j)- &
3806!^ & tl_rzeta(i ,j))+ &
3807#if defined VAR_RHO_2D && defined SOLVE3D
3808!^ & (tl_h(i-1,j)- &
3809!^ & tl_h(i ,j))* &
3810!^ & (rzetaSA(i-1,j)+ &
3811!^ & rzetaSA(i ,j)+ &
3812!^ & cff2*(rhoA(i-1,j)- &
3813!^ & rhoA(i ,j))* &
3814!^ & (zwrk(i-1,j)- &
3815!^ & zwrk(i ,j)))+ &
3816!^ & (h(i-1,j)- &
3817!^ & h(i ,j))* &
3818!^ & (tl_rzetaSA(i-1,j)+ &
3819!^ & tl_rzetaSA(i ,j)+ &
3820!^ & cff2*((tl_rhoA(i-1,j)- &
3821!^ & tl_rhoA(i ,j))* &
3822!^ & (zwrk(i-1,j)- &
3823!^ & zwrk(i ,j))+ &
3824!^ & (rhoA(i-1,j)- &
3825!^ & rhoA(i ,j))* &
3826!^ & (tl_zwrk(i-1,j)- &
3827!^ & tl_zwrk(i ,j))))+ &
3828#endif
3829!^ & (tl_rzeta2(i-1,j)- &
3830!^ & tl_rzeta2(i ,j)))
3831!^
3832 adfac=cff1*on_u(i,j)*ad_rubar(i,j)
3833 adfac1=adfac*(rzeta(i-1,j)-rzeta(i ,j))
3834 adfac2=adfac*(h(i-1,j)+h(i ,j))
3835 ad_h(i-1,j)=ad_h(i-1,j)+adfac1
3836 ad_h(i ,j)=ad_h(i ,j)+adfac1
3837 ad_rzeta(i-1,j)=ad_rzeta(i-1,j)+adfac2
3838 ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2
3839 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac
3840 ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac
3841#if defined VAR_RHO_2D && defined SOLVE3D
3842 adfac3=adfac*(rzetasa(i-1,j)+ &
3843 & rzetasa(i ,j)+ &
3844 & cff2*(rhoa(i-1,j)- &
3845 & rhoa(i ,j))* &
3846 & (zwrk(i-1,j)- &
3847 & zwrk(i ,j)))
3848 adfac4=adfac2*cff2*(zwrk(i-1,j)-zwrk(i,j))
3849 adfac5=adfac2*cff2*(rhoa(i-1,j)-rhoa(i,j))
3850 ad_h(i-1,j)=ad_h(i-1,j)+adfac3
3851 ad_h(i ,j)=ad_h(i ,j)-adfac3
3852 ad_rzetasa(i-1,j)=ad_rzetasa(i-1,j)+adfac2
3853 ad_rzetasa(i ,j)=ad_rzetasa(i ,j)+adfac2
3854 ad_rhoa(i-1,j)=ad_rhoa(i-1,j)+adfac4
3855 ad_rhoa(i ,j)=ad_rhoa(i ,j)-adfac4
3856 ad_zwrk(i-1,j)=ad_zwrk(i-1,j)+adfac5
3857 ad_zwrk(i ,j)=ad_zwrk(i ,j)-adfac5
3858#endif
3859 ad_rubar(i,j)=0.0_r8
3860 END IF
3861 END DO
3862 END DO
3863
3864#ifdef SOLVE3D
3865!
3866!-----------------------------------------------------------------------
3867! Compute fast-time-averaged fields over all barotropic time steps.
3868!-----------------------------------------------------------------------
3869!
3870! Reset/initialize arrays for averaged fields during the first
3871! barotropic time step. Then, accumulate it time average. Include
3872! physical boundary points, but not periodic ghost points or
3873! computation distributed-memory computational margins.
3874!
3875 cff1=weight(1,iif(ng),ng)
3876 cff2=weight(2,iif(ng),ng)
3877!
3878 IF (first_2d_step) THEN
3879 DO j=jstrr,jendr
3880 DO i=istrr,iendr
3881 IF (j.ge.jstr) THEN
3882!^ tl_DV_avg2(i,j)=cff2*tl_DVom(i,j)
3883!^
3884 ad_dvom(i,j)=ad_dvom(i,j)+cff2*ad_dv_avg2(i,j)
3885 ad_dv_avg2(i,j)=0.0_r8
3886!^ tl_DV_avg1(i,j)=0.0_r8
3887!^
3888 ad_dv_avg1(i,j)=0.0_r8
3889 END IF
3890 IF (i.ge.istr) THEN
3891!^ tl_DU_avg2(i,j)=cff2*tl_DUon(i,j)
3892!^
3893 ad_duon(i,j)=ad_duon(i,j)+cff2*ad_du_avg2(i,j)
3894 ad_du_avg2(i,j)=0.0_r8
3895!^ tl_DU_avg1(i,j)=0.0_r8
3896!^
3897 ad_du_avg1(i,j)=0.0_r8
3898 END IF
3899!^ tl_Zt_avg1(i,j)=cff1*tl_zeta(i,j,knew)
3900!^
3901 ad_zeta(i,j,knew)=ad_zeta(i,j,knew)+cff1*ad_zt_avg1(i,j)
3902 ad_zt_avg1(i,j)=0.0_r8
3903 END DO
3904 END DO
3905 ELSE
3906 DO j=jstrr,jendr
3907 DO i=istrr,iendr
3908 IF (j.ge.jstr) THEN
3909!^ tl_DV_avg2(i,j)=tl_DV_avg2(i,j)+cff2*tl_DVom(i,j)
3910!^
3911 ad_dvom(i,j)=ad_dvom(i,j)+cff2*ad_dv_avg2(i,j)
3912 END IF
3913 IF (i.ge.istr) THEN
3914!^ tl_DU_avg2(i,j)=tl_DU_avg2(i,j)+cff2*tl_DUon(i,j)
3915!^
3916 ad_duon(i,j)=ad_duon(i,j)+cff2*ad_du_avg2(i,j)
3917 END IF
3918!^ tl_Zt_avg1(i,j)=tl_Zt_avg1(i,j)+cff1*tl_zeta(i,j,knew)
3919!^
3920 ad_zeta(i,j,knew)=ad_zeta(i,j,knew)+cff1*ad_zt_avg1(i,j)
3921 END DO
3922 END DO
3923 END IF
3924#endif
3925!
3926!-----------------------------------------------------------------------
3927! Adjoint of advance free-surface.
3928!-----------------------------------------------------------------------
3929
3930#ifndef SOLVE3D
3931!
3932! Save free-surface adjoint solution for IO purposes.
3933!
3934 DO j=jstrr,jendr
3935 DO i=istrr,iendr
3936 ad_zeta_sol(i,j)=ad_zeta(i,j,knew)
3937 END DO
3938 END DO
3939#endif
3940!
3941! Load new computed free-surface into global state array.
3942!
3943 DO j=jstrr,jendr
3944 DO i=istrr,iendr
3945!^ tl_zeta(i,j,knew)=tl_zeta_new(i,j)
3946!^
3947 ad_zeta_new(i,j)=ad_zeta_new(i,j)+ad_zeta(i,j,knew)
3948 ad_zeta(i,j,knew)=0.0_r8
3949 END DO
3950 END DO
3951!
3952! Apply boundary conditions to newly computed free-surface "zeta_new".
3953! Notice that we are using the local routine, which passes the private
3954! "zeta_new" array as argument.
3955!
3956! Here, we use the local "zetabc" since the private array "zeta_new"
3957! is passed as an argument to allow computing the lateral boundary
3958! conditions on the range IstrU-1:Iend and JstrV-1:Jend, so parallel
3959! tile exchanges are avoided.
3960!
3961!^ CALL tl_zetabc_local (ng, tile, &
3962!^ & LBi, UBi, LBj, UBj, &
3963!^ & IminS, ImaxS, JminS, JmaxS, &
3964!^ & kstp, &
3965!^ & zeta, tl_zeta, &
3966!^ & zeta_new, tl_zeta_new)
3967!^
3968 CALL ad_zetabc_local (ng, tile, &
3969 & lbi, ubi, lbj, ubj, &
3970 & imins, imaxs, jmins, jmaxs, &
3971 & kstp, &
3972 & zeta, ad_zeta, &
3973 & zeta_new, ad_zeta_new)
3974!
3975! Apply mass point sources (volume vertical influx), if any.
3976!
3977! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
3978!
3979 IF (lwsrc(ng)) THEN
3980 DO is=1,nsrc(ng)
3981 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
3982 i=sources(ng)%Isrc(is)
3983 j=sources(ng)%Jsrc(is)
3984 IF (((istrr.le.i).and.(i.le.iendr)).and. &
3985 & ((jstrr.le.j).and.(j.le.jendr))) THEN
3986!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)+0.0_r8
3987!^
3988! ad_zeta_new(i,j)=ad_zeta_new(i,j)+0.0_r8
3989 END IF
3990 END IF
3991 END DO
3992 END IF
3993!
3994! Compute "zeta_new" at new time step and interpolate it half-step
3995! backward, "zwrk" for the subsequent computation of barotropic
3996! pressure gradient.
3997!
3998 DO j=jstrv-1,jend
3999 DO i=istru-1,iend
4000 fac=dtfast(ng)*pm(i,j)*pn(i,j)
4001#if defined VAR_RHO_2D && defined SOLVE3D
4002!^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ &
4003!^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j))
4004!^
4005 adfac=zwrk(i,j)*ad_rzetasa(i,j)
4006 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4007 & (rhos(i,j)-rhoa(i,j))*ad_rzetasa(i,j)
4008 ad_rhos(i,j)=ad_rhos(i,j)+adfac
4009 ad_rhoa(i,j)=ad_rhoa(i,j)-adfac
4010 ad_rzetasa(i,j)=0.0_r8
4011!^ tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
4012!^ & rzeta(i,j)*tl_zwrk(i,j)
4013!^
4014 ad_rzeta(i,j)=ad_rzeta(i,j)+zwrk(i,j)*ad_rzeta2(i,j)
4015 ad_zwrk(i,j)=ad_zwrk(i,j)+rzeta(i,j)*ad_rzeta2(i,j)
4016 ad_rzeta2(i,j)=0.0_r8
4017!^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ &
4018!^ & tl_rhoS(i,j)*zwrk(i,j)
4019!^
4020 ad_rhos(i,j)=ad_rhos(i,j)+zwrk(i,j)*ad_rzeta(i,j)
4021 ad_zwrk(i,j)=ad_zwrk(i,j)+(1.0_r8+rhos(i,j))*ad_rzeta(i,j)
4022 ad_rzeta(i,j)=0.0_r8
4023#else
4024!^ tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
4025!^ tl_rzeta(i,j)=tl_zwrk(i,j)
4026!^
4027 ad_zwrk(i,j)=ad_zwrk(i,j)+ &
4028 & 2.0_r8*zwrk(i,j)*ad_rzeta2(i,j)+ &
4029 & ad_rzeta(i,j)
4030 ad_rzeta2(i,j)=0.0_r8
4031 ad_rzeta(i,j)=0.0_r8
4032#endif
4033!^ tl_zwrk(i,j)=bkw_new*tl_zeta_new(i,j)+ &
4034!^ & bkw0*tl_zeta(i,j,kstp)+ &
4035!^ & bkw1*tl_zeta(i,j,kbak)+ &
4036!^ & bkw2*tl_zeta(i,j,kold)
4037!^
4038 ad_zeta_new(i,j)=ad_zeta_new(i,j)+bkw_new*ad_zwrk(i,j)
4039 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+bkw0*ad_zwrk(i,j)
4040 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+bkw1*ad_zwrk(i,j)
4041 ad_zeta(i,j,kold)=ad_zeta(i,j,kold)+bkw2*ad_zwrk(i,j)
4042 ad_zwrk(i,j)=0.0_r8
4043#ifdef MASKING
4044# ifdef WET_DRY_NOT_YET
4045!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)- &
4046!^ & tl_h(i,j)*(1.0_r8-rmask(i,j))
4047!^
4048# endif
4049!^ tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
4050!^
4051 ad_zeta_new(i,j)=ad_zeta_new(i,j)*rmask(i,j)
4052#endif
4053!^ tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
4054!^ & fac*(tl_DUon(i,j)-tl_DUon(i+1,j)+ &
4055!^ & tl_DVom(i,j)-tl_DVom(i,j+1))
4056!^
4057 adfac=fac*ad_zeta_new(i,j)
4058 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+ad_zeta_new(i,j)
4059 ad_duon(i ,j)=ad_duon(i ,j)+adfac
4060 ad_duon(i+1,j)=ad_duon(i+1,j)-adfac
4061 ad_dvom(i,j )=ad_dvom(i,j )+adfac
4062 ad_dvom(i,j+1)=ad_dvom(i,j+1)-adfac
4063 ad_zeta_new(i,j)=0.0_r8 ! HGA comment for debugging
4064 END DO
4065 END DO
4066!
4067!-----------------------------------------------------------------------
4068! Adjoint of preliminary steps.
4069!-----------------------------------------------------------------------
4070!
4071! Set vertically integrated mass fluxes DUon and DVom along the open
4072! boundaries in such a way that the integral volume is conserved.
4073!
4074 IF (any(volcons(:,ng))) THEN
4075!^ CALL tl_set_DUV_bc_tile (ng, tile, &
4076!^ & LBi, UBi, LBj, UBj, &
4077!^ & IminS, ImaxS, JminS, JmaxS, &
4078!^ & krhs, &
4079#ifdef MASKING
4080!^ & umask, vmask, &
4081#endif
4082!^ & om_v, on_u, &
4083!^ & ubar, vbar, &
4084!^ & tl_ubar, tl_vbar, &
4085!^ & Drhs, DUon, DVom, &
4086!^ & tl_Drhs, tl_DUon, tl_DVom)
4087!^
4088 CALL ad_set_duv_bc_tile (ng, tile, &
4089 & lbi, ubi, lbj, ubj, &
4090 & imins, imaxs, jmins, jmaxs, &
4091 & krhs, &
4092#ifdef MASKING
4093 & umask, vmask, &
4094#endif
4095 & om_v, on_u, &
4096 & ubar, vbar, &
4097 & ad_ubar, ad_vbar, &
4098 & drhs, duon, dvom, &
4099 & ad_drhs, ad_duon, ad_dvom)
4100!
4101! Compute integral mass flux across open boundaries and adjust
4102! for volume conservation. Compute BASIC STATE value.
4103! HGA: Need to resolve 'krhs' index here.
4104!
4105!^ CALL tl_obc_flux_tile (ng, tile, &
4106!^ & LBi, UBi, LBj, UBj, &
4107!^ & IminS, ImaxS, JminS, JmaxS, &
4108!^ & knew, &
4109# ifdef MASKING
4110!^ & umask, vmask, &
4111# endif
4112!^ & h, tl_h, om_v, on_u, &
4113!^ & ubar, vbar, zeta, &
4114!^ & tl_ubar, tl_vbar, tl_zeta)
4115!^
4116 CALL ad_obc_flux_tile (ng, tile, &
4117 & lbi, ubi, lbj, ubj, &
4118 & imins, imaxs, jmins, jmaxs, &
4119 & knew, &
4120# ifdef MASKING
4121 & umask, vmask, &
4122# endif
4123 & h, ad_h, om_v, on_u, &
4124 & ubar, vbar, zeta, &
4125 & ad_ubar, ad_vbar, ad_zeta)
4126 END IF
4127
4128#if defined DISTRIBUTE && \
4129 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
4130!
4131! In distributed-memory, the I- and J-ranges are different and a
4132! special exchange is done here to avoid having three ghost points
4133! for high-order numerical stencils. Notice that a private array is
4134! passed below to the exchange routine. It also applies periodic
4135! boundary conditions, if appropriate and no partitions in I- or
4136! J-directions.
4137!
4138 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
4139!^ CALL exchange_v2d_tile (ng, tile, &
4140!^ & IminS, ImaxS, JminS, JmaxS, &
4141!^ & tl_DVom)
4142!^
4143 CALL ad_exchange_v2d_tile (ng, tile, &
4144 & imins, imaxs, jmins, jmaxs, &
4145 & ad_dvom)
4146!^ CALL exchange_u2d_tile (ng, tile, &
4147!^ & IminS, ImaxS, JminS, JmaxS, &
4148!^ & tl_DUon)
4149!^
4150 CALL ad_exchange_u2d_tile (ng, tile, &
4151 & imins, imaxs, jmins, jmaxs, &
4152 & ad_duon)
4153 END IF
4154!^ CALL mp_exchange2d (ng, tile, iTLM, 2, &
4155!^ & IminS, ImaxS, JminS, JmaxS, &
4156!^ & NghostPoints, &
4157!^ & EWperiodic(ng), NSperiodic(ng), &
4158!^ & tl_DUon, tl_DVom)
4159!^
4160 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
4161 & imins, imaxs, jmins, jmaxs, &
4162 & nghostpoints, &
4163 & ewperiodic(ng), nsperiodic(ng), &
4164 & ad_duon, ad_dvom)
4165#endif
4166!
4167! Compute total depth of water column and vertically integrated fluxes
4168! needed for computing horizontal divergence to advance free surface
4169! and for nonlinear advection terms for the barotropic momentum
4170! equations.
4171!
4172#if defined DISTRIBUTE && !defined NESTING
4173# define IR_RANGE IstrUm2-1,Iendp2
4174# define JR_RANGE JstrVm2-1,Jendp2
4175# define IU_RANGE IstrUm1-1,Iendp2
4176# define JU_RANGE Jstrm1-1,Jendp2
4177# define IV_RANGE Istrm1-1,Iendp2
4178# define JV_RANGE JstrVm1-1,Jendp2
4179#else
4180# define IR_RANGE IstrUm2-1,Iendp2
4181# define JR_RANGE JstrVm2-1,Jendp2
4182# define IU_RANGE IstrUm2,Iendp2
4183# define JU_RANGE JstrVm2-1,Jendp2
4184# define IV_RANGE IstrUm2-1,Iendp2
4185# define JV_RANGE JstrVm2,Jendp2
4186#endif
4187
4188 DO j=jv_range
4189 DO i=iv_range
4190 cff=0.5_r8*om_v(i,j)
4191 cff1=cff*(drhs(i,j)+drhs(i,j-1))
4192!^ tl_DVom(i,j)=tl_vrhs(i,j)*cff1+ &
4193!^ & vrhs(i,j)*tl_cff1
4194!^
4195 ad_vrhs(i,j)=ad_vrhs(i,j)+cff1*ad_dvom(i,j)
4196 ad_cff1=ad_cff1+vrhs(i,j)*ad_dvom(i,j)
4197 ad_dvom(i,j)=0.0_r8
4198!^ tl_vrhs(i,j)=fwd0*tl_vbar(i,j,kstp)+ &
4199!^ & fwd1*tl_vbar(i,j,kbak)+ &
4200!^ & fwd2*tl_vbar(i,j,kold)
4201!^
4202 ad_vbar(i,j,kstp)=ad_vbar(i,j,kstp)+fwd0*ad_vrhs(i,j)
4203 ad_vbar(i,j,kbak)=ad_vbar(i,j,kbak)+fwd1*ad_vrhs(i,j)
4204 ad_vbar(i,j,kold)=ad_vbar(i,j,kold)+fwd2*ad_vrhs(i,j)
4205 ad_vrhs(i,j)=0.0_r8
4206!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i,j-1))
4207!^
4208 adfac=cff*ad_cff1
4209 ad_drhs(i,j-1)=ad_drhs(i,j-1)+adfac
4210 ad_drhs(i,j )=ad_drhs(i,j )+adfac
4211 ad_cff1=0.0_r8
4212 END DO
4213 END DO
4214!
4215 DO j=ju_range
4216 DO i=iu_range
4217 cff=0.5_r8*on_u(i,j)
4218 cff1=cff*(drhs(i,j)+drhs(i-1,j))
4219!^ tl_DUon(i,j)=tl_urhs(i,j)*cff1+ &
4220!^ & urhs(i,j)*tl_cff1
4221!^
4222 ad_urhs(i,j)=ad_urhs(i,j)+cff1*ad_duon(i,j)
4223 ad_cff1=ad_cff1+urhs(i,j)*ad_duon(i,j)
4224 ad_duon(i,j)=0.0_r8
4225!^ tl_urhs(i,j)=fwd0*tl_ubar(i,j,kstp)+ &
4226!^ & fwd1*tl_ubar(i,j,kbak)+ &
4227!^ & fwd2*tl_ubar(i,j,kold)
4228!^
4229 ad_ubar(i,j,kstp)=ad_ubar(i,j,kstp)+fwd0*ad_urhs(i,j)
4230 ad_ubar(i,j,kbak)=ad_ubar(i,j,kbak)+fwd1*ad_urhs(i,j)
4231 ad_ubar(i,j,kold)=ad_ubar(i,j,kold)+fwd2*ad_urhs(i,j)
4232 ad_urhs(i,j)=0.0_r8
4233!^ tl_cff1=cff*(tl_Drhs(i,j)+tl_Drhs(i-1,j))
4234!^
4235 adfac=cff*ad_cff1
4236 ad_drhs(i-1,j)=ad_drhs(i-1,j)+adfac
4237 ad_drhs(i ,j)=ad_drhs(i ,j)+adfac
4238 ad_cff1=0.0_r8
4239 END DO
4240 END DO
4241!
4242 DO j=jr_range
4243 DO i=ir_range
4244!^ tl_Drhs(i,j)=tl_h(i,j)+fwd0*tl_zeta(i,j,kstp)+ &
4245!^ & fwd1*tl_zeta(i,j,kbak)+ &
4246!^ & fwd2*tl_zeta(i,j,kold)
4247!^
4248 ad_h(i,j)=ad_h(i,j)+ad_drhs(i,j)
4249 ad_zeta(i,j,kstp)=ad_zeta(i,j,kstp)+fwd0*ad_drhs(i,j)
4250 ad_zeta(i,j,kbak)=ad_zeta(i,j,kbak)+fwd1*ad_drhs(i,j)
4251 ad_zeta(i,j,kold)=ad_zeta(i,j,kold)+fwd2*ad_drhs(i,j)
4252 ad_drhs(i,j)=0.0_r8
4253 END DO
4254 END DO
4255
4256#undef IR_RANGE
4257#undef IU_RANGE
4258#undef IV_RANGE
4259#undef JR_RANGE
4260#undef JU_RANGE
4261#undef JV_RANGE
4262!
4263! Deallocate local new free-surface.
4264!
4265 deallocate ( ad_zeta_new )
4266!
4267 RETURN

References ad_exchange_2d_mod::ad_exchange_r2d_tile(), ad_exchange_2d_mod::ad_exchange_u2d_tile(), ad_exchange_2d_mod::ad_exchange_v2d_tile(), mp_exchange_mod::ad_mp_exchange2d(), ad_obc_volcons_mod::ad_obc_flux_tile(), ad_set_depth_mod::ad_set_depth(), ad_obc_volcons_mod::ad_set_duv_bc_tile(), ad_u2dbc_mod::ad_u2dbc_tile(), ad_v2dbc_mod::ad_v2dbc_tile(), mod_scalars::compositegrid, mod_param::domain, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_param::iadm, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_param::inlm, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_scalars::luvsrc, mod_scalars::lwsrc, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, mod_scalars::ntstart, obc_volcons_mod::obc_flux_tile(), mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, mod_scalars::volcons, and mod_scalars::weight.

Referenced by ad_step2d().

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