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

Functions/Subroutines

subroutine, public ad_rhs3d (ng, tile)
 
subroutine ad_rhs3d_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, knew, nrhs, hz, ad_hz, huon, ad_huon, hvom, ad_hvom, dmde, dndx, fomn, om_u, om_v, on_u, on_v, pm, pn, umask_wet, vmask_wet, bustr, ad_bustr, bvstr, ad_bvstr, sustr, ad_sustr, svstr, ad_svstr, u, ad_u, v, ad_v, w, ad_w, ad_rufrc, ad_rvfrc, ad_ru, ad_rv)
 

Function/Subroutine Documentation

◆ ad_rhs3d()

subroutine, public ad_rhs3d_mod::ad_rhs3d ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 28 of file ad_rhs3d.F.

29!***********************************************************************
30!
31 USE mod_param
32 USE mod_coupling
33# ifdef DIAGNOSTICS_UV
34 USE mod_diags
35# endif
36 USE mod_forces
37 USE mod_grid
38# ifdef WEC_MELLOR
39 USE mod_mixing
40# endif
41 USE mod_ocean
42 USE mod_stepping
43# ifdef RPM_RELAXATION
44 USE mod_fourdvar
45# endif
46!
47 USE ad_pre_step3d_mod, ONLY : ad_pre_step3d
48 USE ad_prsgrd_mod, ONLY : ad_prsgrd
49# ifndef TS_FIXED
50# ifdef TS_DIF2
51 USE ad_t3dmix2_mod, ONLY : ad_t3dmix2
52# endif
53# ifdef TS_DIF4
54 USE ad_t3dmix4_mod, ONLY : ad_t3dmix4
55# endif
56# endif
57# ifdef RPM_RELAXATION
58 USE ad_t3drelax_mod, ONLY : ad_t3drelax
59 USE ad_uv3drelax_mod, ONLY : ad_uv3drelax
60# endif
61# ifdef UV_VIS2
62 USE ad_uv3dmix2_mod, ONLY : ad_uv3dmix2
63# endif
64# ifdef UV_VIS4
65 USE ad_uv3dmix4_mod, ONLY : ad_uv3dmix4
66# endif
67!
68! Imported variable declarations.
69!
70 integer, intent(in) :: ng, tile
71!
72! Local variable declarations.
73!
74 character (len=*), parameter :: MyFile = &
75 & __FILE__
76!
77# include "tile.h"
78# ifdef RPM_RELAXATION
79!
80!-----------------------------------------------------------------------
81! Improve stability and convergence of the tangent linear representer
82! model 3D momentum by a "diffusive relaxation" to previous Picard
83! iteration solution. Only applied in the call to ad_main3d in outer
84! loop.
85!-----------------------------------------------------------------------
86!
87 IF (lweakrelax(ng)) THEN
88 CALL ad_uv3drelax (ng, tile)
89 END IF
90# endif
91# ifdef UV_VIS4
92!
93!-----------------------------------------------------------------------
94! Compute horizontal, biharmonic mixing of momentum.
95!-----------------------------------------------------------------------
96!
97 CALL ad_uv3dmix4 (ng, tile)
98# endif
99# ifdef UV_VIS2
100!
101!-----------------------------------------------------------------------
102! Compute horizontal, harmonic mixing of momentum.
103!-----------------------------------------------------------------------
104!
105 CALL ad_uv3dmix2 (ng, tile)
106# endif
107!
108!-----------------------------------------------------------------------
109! Compute right-hand-side terms for the 3D momentum equations.
110!-----------------------------------------------------------------------
111!
112# ifdef PROFILE
113 CALL wclock_on (ng, iadm, 21, __line__, myfile)
114# endif
115 CALL ad_rhs3d_tile (ng, tile, &
116 & lbi, ubi, lbj, ubj, &
117 & imins, imaxs, jmins, jmaxs, &
118 & knew(ng), nrhs(ng), &
119 & grid(ng) % Hz, &
120 & grid(ng) % ad_Hz, &
121 & grid(ng) % Huon, &
122 & grid(ng) % ad_Huon, &
123 & grid(ng) % Hvom, &
124 & grid(ng) % ad_Hvom, &
125# if defined CURVGRID && defined UV_ADV
126 & grid(ng) % dmde, &
127 & grid(ng) % dndx, &
128# endif
129 & grid(ng) % fomn, &
130 & grid(ng) % om_u, &
131 & grid(ng) % om_v, &
132 & grid(ng) % on_u, &
133 & grid(ng) % on_v, &
134 & grid(ng) % pm, &
135 & grid(ng) % pn, &
136# ifdef WET_DRY_NOT_YET
137 & grid(ng)%umask_wet, &
138 & grid(ng)%vmask_wet, &
139# endif
140 & forces(ng) % bustr, &
141 & forces(ng) % ad_bustr, &
142 & forces(ng) % bvstr, &
143 & forces(ng) % ad_bvstr, &
144 & forces(ng) % sustr, &
145 & forces(ng) % ad_sustr, &
146 & forces(ng) % svstr, &
147 & forces(ng) % ad_svstr, &
148 & ocean(ng) % u, &
149 & ocean(ng) % ad_u, &
150 & ocean(ng) % v, &
151 & ocean(ng) % ad_v, &
152 & ocean(ng) % W, &
153 & ocean(ng) % ad_W, &
154# ifdef WEC_MELLOR
155 & ocean(ng) % u_stokes, &
156 & ocean(ng) % ad_u_stokes, &
157 & ocean(ng) % v_stokes, &
158 & ocean(ng) % ad_v_stokes, &
159 & ocean(ng) % ad_rulag3d, &
160 & ocean(ng) % ad_rvlag3d, &
161 & mixing(ng) % ad_rustr3d, &
162 & mixing(ng) % ad_rvstr3d, &
163# endif
164 & coupling(ng) % ad_rufrc, &
165 & coupling(ng) % ad_rvfrc, &
166# ifdef DIAGNOSTICS_UV
167!! & DIAGS(ng) % DiaRUfrc, &
168!! & DIAGS(ng) % DiaRVfrc, &
169!! & DIAGS(ng) % DiaRU, &
170!! & DIAGS(ng) % DiaRV, &
171# endif
172 & ocean(ng) % ad_ru, &
173 & ocean(ng) % ad_rv)
174# ifdef PROFILE
175 CALL wclock_off (ng, iadm, 21, __line__, myfile)
176# endif
177# ifdef RPM_RELAXATION
178!
179!-----------------------------------------------------------------------
180! Improve stability and convergence of the tangent linear representer
181! model tracer type variables by a "diffusive relaxation" to previous
182! Picard iteration solution. Only applied in the call to ad_main3d in
183! outer loop.
184!-----------------------------------------------------------------------
185!
186 IF (lweakrelax(ng)) THEN
187 CALL ad_t3drelax (ng, tile)
188 END IF
189# endif
190# ifndef TS_FIXED
191# ifdef TS_DIF4
192!
193!-----------------------------------------------------------------------
194! Compute horizontal biharmonic mixing of tracer type variables.
195!-----------------------------------------------------------------------
196!
197 CALL ad_t3dmix4 (ng, tile)
198# endif
199# ifdef TS_DIF2
200!
201!-----------------------------------------------------------------------
202! Compute horizontal harmonic mixing of tracer type variables.
203!-----------------------------------------------------------------------
204!
205 CALL ad_t3dmix2 (ng, tile)
206# endif
207# endif
208!
209!-----------------------------------------------------------------------
210! Compute baroclinic pressure gradient.
211!-----------------------------------------------------------------------
212!
213 CALL ad_prsgrd (ng, tile)
214!
215!-----------------------------------------------------------------------
216! Initialize computations for new time step of the 3D primitive
217! variables.
218!-----------------------------------------------------------------------
219!
220 CALL ad_pre_step3d (ng, tile)
221 RETURN
ad_pre_step3d_mod
Definition ad_pre_step3d.F:2
ad_pre_step3d_mod::ad_pre_step3d
subroutine, public ad_pre_step3d(ng, tile)
Definition ad_pre_step3d.F:45
ad_prsgrd_mod
Definition ad_prsgrd31.h:1
ad_prsgrd_mod::ad_prsgrd
subroutine, public ad_prsgrd(ng, tile)
Definition ad_prsgrd31.h:37
ad_t3dmix2_mod
Definition ad_t3dmix2_geo.h:1
ad_t3dmix2_mod::ad_t3dmix2
subroutine, public ad_t3dmix2(ng, tile)
Definition ad_t3dmix2_geo.h:26
ad_t3dmix4_mod
Definition ad_t3dmix4_geo.h:1
ad_t3dmix4_mod::ad_t3dmix4
subroutine, public ad_t3dmix4(ng, tile)
Definition ad_t3dmix4_geo.h:26
ad_t3drelax_mod
Definition ad_t3drelax.F:2
ad_t3drelax_mod::ad_t3drelax
subroutine, public ad_t3drelax(ng, tile)
Definition ad_t3drelax.F:29
ad_uv3dmix2_mod
Definition ad_uv3dmix2_geo.h:1
ad_uv3dmix2_mod::ad_uv3dmix2
subroutine, public ad_uv3dmix2(ng, tile)
Definition ad_uv3dmix2_geo.h:43
ad_uv3dmix4_mod
Definition ad_uv3dmix4_geo.h:1
ad_uv3dmix4_mod::ad_uv3dmix4
subroutine, public ad_uv3dmix4(ng, tile)
Definition ad_uv3dmix4_geo.h:43
ad_uv3drelax_mod
Definition ad_uv3drelax.F:2
ad_uv3drelax_mod::ad_uv3drelax
subroutine, public ad_uv3drelax(ng, tile)
Definition ad_uv3drelax.F:29
mod_coupling
Definition mod_coupling.F:2
mod_coupling::coupling
type(t_coupling), dimension(:), allocatable coupling
Definition mod_coupling.F:102
mod_diags
Definition mod_diags.F:2
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_fourdvar
Definition mod_fourdvar.F:2
mod_fourdvar::lweakrelax
logical, dimension(:), allocatable lweakrelax
Definition mod_fourdvar.F:890
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_mixing
Definition mod_mixing.F:2
mod_mixing::mixing
type(t_mixing), dimension(:), allocatable mixing
Definition mod_mixing.F:399
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
mod_stepping
Definition mod_stepping.F:2
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
mod_stepping::nrhs
integer, dimension(:), allocatable nrhs
Definition mod_stepping.F:70
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References ad_pre_step3d_mod::ad_pre_step3d(), ad_prsgrd_mod::ad_prsgrd(), ad_rhs3d_tile(), ad_t3dmix2_mod::ad_t3dmix2(), ad_t3dmix4_mod::ad_t3dmix4(), ad_t3drelax_mod::ad_t3drelax(), ad_uv3dmix2_mod::ad_uv3dmix2(), ad_uv3dmix4_mod::ad_uv3dmix4(), ad_uv3drelax_mod::ad_uv3drelax(), mod_coupling::coupling, mod_forces::forces, mod_grid::grid, mod_param::iadm, mod_stepping::knew, mod_fourdvar::lweakrelax, mod_mixing::mixing, mod_stepping::nrhs, mod_ocean::ocean, 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_rhs3d_tile()

subroutine ad_rhs3d_mod::ad_rhs3d_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) knew,
integer, intent(in) nrhs,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_hz,
real(r8), dimension(lbi:,lbj:,:), intent(in) huon,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_huon,
real(r8), dimension(lbi:,lbj:,:), intent(in) hvom,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_hvom,
real(r8), dimension(lbi:,lbj:), intent(in) dmde,
real(r8), dimension(lbi:,lbj:), intent(in) dndx,
real(r8), dimension(lbi:,lbj:), intent(in) fomn,
real(r8), dimension(lbi:,lbj:), intent(in) om_u,
real(r8), dimension(lbi:,lbj:), intent(in) om_v,
real(r8), dimension(lbi:,lbj:), intent(in) on_u,
real(r8), dimension(lbi:,lbj:), intent(in) on_v,
real(r8), dimension(lbi:,lbj:), intent(in) pm,
real(r8), dimension(lbi:,lbj:), intent(in) pn,
real(r8), dimension(lbi:,lbj:), intent(in) umask_wet,
real(r8), dimension(lbi:,lbj:), intent(in) vmask_wet,
real(r8), dimension(lbi:,lbj:), intent(in) bustr,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_bustr,
real(r8), dimension(lbi:,lbj:), intent(in) bvstr,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_bvstr,
real(r8), dimension(lbi:,lbj:), intent(in) sustr,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_sustr,
real(r8), dimension(lbi:,lbj:), intent(in) svstr,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_svstr,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(in) v,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) ad_v,
real(r8), dimension(lbi:,lbj:,0:), intent(in) w,
real(r8), dimension(lbi:,lbj:,0:), intent(inout) ad_w,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_rufrc,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_rvfrc,
real(r8), dimension(lbi:,lbj:,0:,:), intent(inout) ad_ru,
real(r8), dimension(lbi:,lbj:,0:,:), intent(inout) ad_rv )
private

Definition at line 225 of file ad_rhs3d.F.

260!***********************************************************************
261!
262 USE mod_param
263 USE mod_clima
264 USE mod_scalars
265!
266! Imported variable declarations.
267!
268 integer, intent(in) :: ng, tile
269 integer, intent(in) :: LBi, UBi, LBj, UBj
270 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
271 integer, intent(in) :: knew, nrhs
272!
273# ifdef ASSUMED_SHAPE
274 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
275 real(r8), intent(in) :: Huon(LBi:,LBj:,:)
276 real(r8), intent(in) :: Hvom(LBi:,LBj:,:)
277# if defined CURVGRID && defined UV_ADV
278 real(r8), intent(in) :: dmde(LBi:,LBj:)
279 real(r8), intent(in) :: dndx(LBi:,LBj:)
280# endif
281 real(r8), intent(in) :: fomn(LBi:,LBj:)
282 real(r8), intent(in) :: om_u(LBi:,LBj:)
283 real(r8), intent(in) :: om_v(LBi:,LBj:)
284 real(r8), intent(in) :: on_u(LBi:,LBj:)
285 real(r8), intent(in) :: on_v(LBi:,LBj:)
286 real(r8), intent(in) :: pm(LBi:,LBj:)
287 real(r8), intent(in) :: pn(LBi:,LBj:)
288# ifdef WET_DRY_NOT_YET
289 real(r8), intent(in) :: umask_wet(LBi:,LBj:)
290 real(r8), intent(in) :: vmask_wet(LBi:,LBj:)
291# endif
292 real(r8), intent(in) :: bustr(LBi:,LBj:)
293 real(r8), intent(in) :: bvstr(LBi:,LBj:)
294 real(r8), intent(in) :: sustr(LBi:,LBj:)
295 real(r8), intent(in) :: svstr(LBi:,LBj:)
296 real(r8), intent(in) :: u(LBi:,LBj:,:,:)
297 real(r8), intent(in) :: v(LBi:,LBj:,:,:)
298 real(r8), intent(in) :: W(LBi:,LBj:,0:)
299# ifdef WEC_MELLOR
300 real(r8), intent(in) :: u_stokes(LBi:,LBj:,:)
301 real(r8), intent(in) :: v_stokes(LBi:,LBj:,:)
302# endif
303# ifdef DIAGNOSTICS_UV
304!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
305!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
306!! real(r8), intent(inout) :: DiaRU(LBi:,LBj:,:,:,:)
307!! real(r8), intent(inout) :: DiaRV(LBi:,LBj:,:,:,:)
308# endif
309 real(r8), intent(inout) :: ad_Hz(LBi:,LBj:,:)
310 real(r8), intent(inout) :: ad_Huon(LBi:,LBj:,:)
311 real(r8), intent(inout) :: ad_Hvom(LBi:,LBj:,:)
312 real(r8), intent(inout) :: ad_bustr(LBi:,LBj:)
313 real(r8), intent(inout) :: ad_bvstr(LBi:,LBj:)
314 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
315 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
316 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
317 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
318 real(r8), intent(inout) :: ad_W(LBi:,LBj:,0:)
319# ifdef WEC_MELLOR
320 real(r8), intent(inout) :: ad_u_stokes(LBi:,LBj:,:)
321 real(r8), intent(inout) :: ad_v_stokes(LBi:,LBj:,:)
322 real(r8), intent(inout) :: ad_rulag3d(LBi:,LBj:,:)
323 real(r8), intent(inout) :: ad_rvlag3d(LBi:,LBj:,:)
324 real(r8), intent(inout) :: ad_rustr3d(LBi:,LBj:,:)
325 real(r8), intent(inout) :: ad_rvstr3d(LBi:,LBj:,:)
326# endif
327 real(r8), intent(inout) :: ad_ru(LBi:,LBj:,0:,:)
328 real(r8), intent(inout) :: ad_rv(LBi:,LBj:,0:,:)
329
330 real(r8), intent(inout) :: ad_rufrc(LBi:,LBj:)
331 real(r8), intent(inout) :: ad_rvfrc(LBi:,LBj:)
332# else
333 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
334 real(r8), intent(in) :: Huon(LBi:UBi,LBj:UBj,N(ng))
335 real(r8), intent(in) :: Hvom(LBi:UBi,LBj:UBj,N(ng))
336# if defined CURVGRID && defined UV_ADV
337 real(r8), intent(in) :: dmde(LBi:UBi,LBj:UBj)
338 real(r8), intent(in) :: dndx(LBi:UBi,LBj:UBj)
339# endif
340 real(r8), intent(in) :: fomn(LBi:UBi,LBj:UBj)
341 real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj)
342 real(r8), intent(in) :: om_v(LBi:UBi,LBj:UBj)
343 real(r8), intent(in) :: on_u(LBi:UBi,LBj:UBj)
344 real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj)
345 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
346 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
347# ifdef WET_DRY_NOT_YET
348 real(r8), intent(in) :: umask_wet(LBi:UBi,LBj:UBj)
349 real(r8), intent(in) :: vmask_wet(LBi:UBi,LBj:UBj)
350# endif
351 real(r8), intent(in) :: bustr(LBi:UBi,LBj:UBj)
352 real(r8), intent(in) :: bvstr(LBi:UBi,LBj:UBj)
353 real(r8), intent(in) :: sustr(LBi:UBi,LBj:UBj)
354 real(r8), intent(in) :: svstr(LBi:UBi,LBj:UBj)
355 real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2)
356 real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2)
357 real(r8), intent(in) :: W(LBi:UBi,LBj:UBj,0:N(ng))
358# ifdef WEC_MELLOR
359 real(r8), intent(in) :: u_stokes(LBi:UBi,LBj:UBj,N(ng))
360 real(r8), intent(in) :: v_stokes(LBi:UBi,LBj:UBj,N(ng))
361# endif
362# ifdef DIAGNOSTICS_UV
363!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
364!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
365!! real(r8), intent(inout) :: DiaRU(LBi:UBi,LBj:UBj,N(ng),2,NDrhs)
366!! real(r8), intent(inout) :: DiaRV(LBi:UBi,LBj:UBj,N(ng),2,NDrhs)
367# endif
368 real(r8), intent(inout) :: ad_Hz(LBi:UBi,LBj:UBj,N(ng))
369 real(r8), intent(inout) :: ad_Huon(LBi:UBi,LBj:UBj,N(ng))
370 real(r8), intent(inout) :: ad_Hvom(LBi:UBi,LBj:UBj,N(ng))
371 real(r8), intent(inout) :: ad_bustr(LBi:UBi,LBj:UBj)
372 real(r8), intent(inout) :: ad_bvstr(LBi:UBi,LBj:UBj)
373 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
374 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
375 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
376 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
377 real(r8), intent(inout) :: ad_W(LBi:UBi,LBj:UBj,0:N(ng))
378# ifdef WEC_MELLOR
379 real(r8), intent(inout) :: ad_u_stokes(LBi:UBi,LBj:UBj,N(ng))
380 real(r8), intent(inout) :: ad_v_stokes(LBi:UBi,LBj:UBj,N(ng))
381 real(r8), intent(inout) :: ad_rulag3d(LBi:UBi,LBj:UBj,N(ng))
382 real(r8), intent(inout) :: ad_rvlag3d(LBi:UBi,LBj:UBj,N(ng))
383 real(r8), intent(inout) :: ad_rustr3d(LBi:UBi,LBj:UBj,N(ng))
384 real(r8), intent(inout) :: ad_rvstr3d(LBi:UBi,LBj:UBj,N(ng))
385# endif
386 real(r8), intent(inout) :: ad_ru(LBi:UBi,LBj:UBj,0:N(ng),2)
387 real(r8), intent(inout) :: ad_rv(LBi:UBi,LBj:UBj,0:N(ng),2)
388
389 real(r8), intent(inout) :: ad_rufrc(LBi:UBi,LBj:UBj)
390 real(r8), intent(inout) :: ad_rvfrc(LBi:UBi,LBj:UBj)
391# endif
392!
393! Local variable declarations.
394!
395 integer :: i, j, k
396
397 real(r8), parameter :: Gadv = -0.25_r8
398
399 real(r8) :: cff, cff1, cff2, cff3, cff4
400 real(r8) :: ad_cff, ad_cff1, ad_cff2, ad_cff3, ad_cff4
401 real(r8) :: adfac, adfac1, adfac2, adfac3, adfac4, adfac5
402
403 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
404 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
405 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC
406
407 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: ad_CF
408 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: ad_DC
409 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: ad_FC
410
411 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Huee
412 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Huxx
413 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Hvee
414 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Hvxx
415 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
416 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
417 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
418 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
419 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
420 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
421 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: uee
422 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: uxx
423 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: vee
424 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: vxx
425 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wrk
426
427 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Huee
428 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Huxx
429 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Hvee
430 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Hvxx
431 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFx
432 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_UFe
433 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Uwrk
434 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFx
435 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_VFe
436 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_Vwrk
437 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_uee
438 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_uxx
439 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_vee
440 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_vxx
441 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_wrk
442
443# include "set_bounds.h"
444!
445!-----------------------------------------------------------------------
446! Initialize adjoint private variables.
447!-----------------------------------------------------------------------
448!
449 ad_cff=0.0_r8
450 ad_cff1=0.0_r8
451 ad_cff2=0.0_r8
452 ad_cff3=0.0_r8
453 ad_cff4=0.0_r8
454 DO j=jmins,jmaxs
455 DO i=imins,imaxs
456 ad_huee(i,j)=0.0_r8
457 ad_huxx(i,j)=0.0_r8
458 ad_hvee(i,j)=0.0_r8
459 ad_hvxx(i,j)=0.0_r8
460 ad_ufx(i,j)=0.0_r8
461 ad_ufe(i,j)=0.0_r8
462 ad_vfx(i,j)=0.0_r8
463 ad_vfe(i,j)=0.0_r8
464 ad_uwrk(i,j)=0.0_r8
465 ad_vwrk(i,j)=0.0_r8
466 ad_uee(i,j)=0.0_r8
467 ad_uxx(i,j)=0.0_r8
468 ad_vee(i,j)=0.0_r8
469 ad_vxx(i,j)=0.0_r8
470 ad_wrk(i,j)=0.0_r8
471 END DO
472 END DO
473 DO k=0,n(ng)
474 DO i=imins,imaxs
475 ad_cf(i,k)=0.0_r8
476 ad_dc(i,k)=0.0_r8
477 ad_fc(i,k)=0.0_r8
478 END DO
479 END DO
480!
481 j_loop : DO j=jstr,jend
482!
483!-----------------------------------------------------------------------
484! Compute forcing term for the 2D momentum equations.
485!-----------------------------------------------------------------------
486!
487! Vertically integrate baroclinic right-hand-side terms. If not
488! body force stresses, add in the difference between surface and
489! bottom stresses.
490!
491 IF (j.ge.jstrv) THEN
492# ifndef BODYFORCE
493 DO i=istr,iend
494 cff=om_v(i,j)*on_v(i,j)
495# ifdef DIAGNOSTICS_UV
496!! DiaRVfrc(i,j,3,M2bstr)=cff2
497!! DiaRVfrc(i,j,3,M2sstr)=cff1
498# endif
499# ifdef WET_DRY_NOT_YET
500!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)*vmask_wet(i,j)
501!^
502 ad_rvfrc(i,j)=ad_rvfrc(i,j)*vmask_wet(i,j)
503# endif
504!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)+tl_cff1+tl_cff2
505!^
506 ad_cff1=ad_cff1+ad_rvfrc(i,j)
507 ad_cff2=ad_cff2+ad_rvfrc(i,j)
508!^ tl_cff2=-tl_bvstr(i,j)*cff
509!^
510 ad_bvstr(i,j)=ad_bvstr(i,j)-cff*ad_cff2
511 ad_cff2=0.0_r8
512!^ tl_cff1= tl_svstr(i,j)*cff
513!^
514 ad_svstr(i,j)=ad_svstr(i,j)+cff*ad_cff1
515 ad_cff1=0.0_r8
516 END DO
517# endif
518 DO k=2,n(ng)
519 DO i=istr,iend
520# ifdef DIAGNOSTICS_UV
521# ifdef BODYFORCE
522!! DiaRVfrc(i,j,3,M2strs)=DiaRVfrc(i,j,3,M2strs)+ &
523!! & DiaRV(i,j,k,nrhs,M3vvis)
524# endif
525# ifdef WEC_MELLOR
526!! DiaRVfrc(i,j,3,M2hrad)=DiaRVfrc(i,j,3,M2hrad)+ &
527!! & DiaRV(i,j,k,nrhs,M3hrad)
528# endif
529# ifdef UV_ADV
530!! DiaRVfrc(i,j,3,M2hadv)=DiaRVfrc(i,j,3,M2hadv)+ &
531!! & DiaRV(i,j,k,nrhs,M3hadv)
532!! DiaRVfrc(i,j,3,M2yadv)=DiaRVfrc(i,j,3,M2yadv)+ &
533!! & DiaRV(i,j,k,nrhs,M3yadv)
534!! DiaRVfrc(i,j,3,M2xadv)=DiaRVfrc(i,j,3,M2xadv)+ &
535!! & DiaRV(i,j,k,nrhs,M3xadv)
536# endif
537# ifdef UV_COR
538!! DiaRVfrc(i,j,3,M2fcor)=DiaRVfrc(i,j,3,M2fcor)+ &
539!! & DiaRV(i,j,k,nrhs,M3fcor)
540# endif
541!! DiaRVfrc(i,j,3,M2pgrd)=DiaRVfrc(i,j,3,M2pgrd)+ &
542!! & DiaRV(i,j,k,nrhs,M3pgrd)
543# endif
544!^ tl_rvfrc(i,j)=tl_rvfrc(i,j)+tl_rv(i,j,k,nrhs)
545!^
546 ad_rv(i,j,k,nrhs)=ad_rv(i,j,k,nrhs)+ad_rvfrc(i,j)
547# ifdef WET_DRY_NOT_YET
548!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)*vmask_wet(i,j)
549!^
550 ad_rv(i,j,k,nrhs)=ad_rv(i,j,k,nrhs)*vmask_wet(i,j)
551# endif
552 END DO
553 END DO
554 DO i=istr,iend
555# ifdef DIAGNOSTICS_UV
556# ifdef BODYFORCE
557!! DiaRVfrc(i,j,3,M2strs)=DiaRV(i,j,1,nrhs,M3vvis)
558# endif
559# if defined UV_VIS2 || defined UV_VIS4
560!! DiaRVfrc(i,j,3,M2yvis)=0.0_r8
561!! DiaRVfrc(i,j,3,M2xvis)=0.0_r8
562!! DiaRVfrc(i,j,3,M2hvis)=0.0_r8
563# endif
564# ifdef WEC_MELLOR
565!! DiaRVfrc(i,j,3,M2hrad)=DiaRV(i,j,1,nrhs,M3hrad)
566# endif
567# ifdef UV_ADV
568!! DiaRVfrc(i,j,3,M2hadv)=DiaRV(i,j,1,nrhs,M3hadv)
569!! DiaRVfrc(i,j,3,M2yadv)=DiaRV(i,j,1,nrhs,M3yadv)
570!! DiaRVfrc(i,j,3,M2xadv)=DiaRV(i,j,1,nrhs,M3xadv)
571# endif
572# ifdef UV_COR
573!! DiaRVfrc(i,j,3,M2fcor)=DiaRV(i,j,1,nrhs,M3fcor)
574# endif
575!! DiaRVfrc(i,j,3,M2pgrd)=DiaRV(i,j,1,nrhs,M3pgrd)
576# endif
577!^ tl_rvfrc(i,j)=tl_rv(i,j,1,nrhs)
578!^
579 ad_rv(i,j,1,nrhs)=ad_rv(i,j,1,nrhs)+ad_rvfrc(i,j)
580 ad_rvfrc(i,j)=0.0_r8
581# ifdef WET_DRY_NOT_YET
582!^ tl_rv(i,j,1,nrhs)=tl_rv(i,j,1,nrhs)*vmask_wet(i,j)
583!^
584 ad_rv(i,j,1,nrhs)=ad_rv(i,j,1,nrhs)*vmask_wet(i,j)
585# endif
586 END DO
587 END IF
588# ifndef BODYFORCE
589 DO i=istru,iend
590 cff=om_u(i,j)*on_u(i,j)
591# ifdef DIAGNOSTICS_UV
592!! DiaRUfrc(i,j,3,M2bstr)=cff2
593!! DiaRUfrc(i,j,3,M2sstr)=cff1
594# endif
595# ifdef WET_DRY_NOT_YET
596!> tl_rufrc(i,j)=tl_rufrc(i,j)*umask_wet(i,j)
597!>
598 at_rufrc(i,j)=ad_rufrc(i,j)*umask_wet(i,j)
599# endif
600!^ tl_rufrc(i,j)=tl_rufrc(i,j)+tl_cff1+tl_cff2
601!^
602 ad_cff1=ad_cff1+ad_rufrc(i,j)
603 ad_cff2=ad_cff2+ad_rufrc(i,j)
604!^ tl_cff2=-tl_bustr(i,j)*cff
605!^
606 ad_bustr(i,j)=ad_bustr(i,j)-cff*ad_cff2
607 ad_cff2=0.0_r8
608!^ tl_cff1= tl_sustr(i,j)*cff
609!^
610 ad_sustr(i,j)=ad_sustr(i,j)+cff*ad_cff1
611 ad_cff1=0.0_r8
612 END DO
613# endif
614 DO k=2,n(ng)
615 DO i=istru,iend
616# ifdef DIAGNOSTICS_UV
617# ifdef BODYFORCE
618!! DiaRUfrc(i,j,3,M2strs)=DiaRUfrc(i,j,3,M2strs)+ &
619!! & DiaRU(i,j,k,nrhs,M3vvis)
620# endif
621# ifdef WEC_MELLOR
622!! DiaRUfrc(i,j,3,M2hrad)=DiaRUfrc(i,j,3,M2hrad)+ &
623!! & DiaRU(i,j,k,nrhs,M3hrad)
624# endif
625# ifdef UV_ADV
626!! DiaRUfrc(i,j,3,M2hadv)=DiaRUfrc(i,j,3,M2hadv)+ &
627!! & DiaRU(i,j,k,nrhs,M3hadv)
628!! DiaRUfrc(i,j,3,M2yadv)=DiaRUfrc(i,j,3,M2yadv)+ &
629!! & DiaRU(i,j,k,nrhs,M3yadv)
630!! DiaRUfrc(i,j,3,M2xadv)=DiaRUfrc(i,j,3,M2xadv)+ &
631!! & DiaRU(i,j,k,nrhs,M3xadv)
632# endif
633# ifdef UV_COR
634!! DiaRUfrc(i,j,3,M2fcor)=DiaRUfrc(i,j,3,M2fcor)+ &
635!! & DiaRU(i,j,k,nrhs,M3fcor)
636# endif
637!! DiaRUfrc(i,j,3,M2pgrd)=DiaRUfrc(i,j,3,M2pgrd)+ &
638!! & DiaRU(i,j,k,nrhs,M3pgrd)
639# endif
640!^ tl_rufrc(i,j)=tl_rufrc(i,j)+tl_ru(i,j,k,nrhs)
641!^
642 ad_ru(i,j,k,nrhs)=ad_ru(i,j,k,nrhs)+ad_rufrc(i,j)
643# ifdef WET_DRY_NOT_YET
644!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)*umask_wet(i,j)
645!^
646 ad_ru(i,j,k,nrhs)=ad_ru(i,j,k,nrhs)*umask_wet(i,j)
647# endif
648 END DO
649 END DO
650 DO i=istru,iend
651# ifdef DIAGNOSTICS_UV
652# ifdef BODYFORCE
653!! DiaRUfrc(i,j,3,M2strs)=DiaRU(i,j,1,nrhs,M3vvis)
654# endif
655# if defined UV_VIS2 || defined UV_VIS4
656!! DiaRUfrc(i,j,3,M2hvis)=0.0_r8
657!! DiaRUfrc(i,j,3,M2yvis)=0.0_r8
658!! DiaRUfrc(i,j,3,M2xvis)=0.0_r8
659# endif
660# ifdef WEC_MELLOR
661!! DiaRUfrc(i,j,3,M2hrad)=DiaRU(i,j,1,nrhs,M3hrad)
662# endif
663# ifdef UV_ADV
664!! DiaRUfrc(i,j,3,M2hadv)=DiaRU(i,j,1,nrhs,M3hadv)
665!! DiaRUfrc(i,j,3,M2yadv)=DiaRU(i,j,1,nrhs,M3yadv)
666!! DiaRUfrc(i,j,3,M2xadv)=DiaRU(i,j,1,nrhs,M3xadv)
667# endif
668# ifdef UV_COR
669!! DiaRUfrc(i,j,3,M2fcor)=DiaRU(i,j,1,nrhs,M3fcor)
670# endif
671!! DiaRUfrc(i,j,3,M2pgrd)=DiaRU(i,j,1,nrhs,M3pgrd)
672# endif
673!^ tl_rufrc(i,j)=tl_ru(i,j,1,nrhs)
674!^
675 ad_ru(i,j,1,nrhs)=ad_ru(i,j,1,nrhs)+ad_rufrc(i,j)
676 ad_rufrc(i,j)=0.0_r8
677# ifdef WET_DRY_NOT_YET
678!^ tl_ru(i,j,1,nrhs)=tl_ru(i,j,1,nrhs)*umask_wet(i,j)
679!^
680 ad_ru(i,j,1,nrhs)=ad_ru(i,j,1,nrhs)*umask_wet(i,j)
681# endif
682 END DO
683# ifdef UV_ADV
684!
685!-----------------------------------------------------------------------
686! Add in adjoint vertical advection, V-momentum.
687!-----------------------------------------------------------------------
688!
689 IF (j.ge.jstrv) THEN
690 DO k=1,n(ng)
691 DO i=istr,iend
692# ifdef DIAGNOSTICS_UV
693!! DiaRV(i,j,k,nrhs,M3vadv)=-cff
694# endif
695!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)-tl_cff
696!^
697 ad_cff=ad_cff-ad_rv(i,j,k,nrhs)
698!^ tl_cff=tl_FC(i,k)-tl_FC(i,k-1)
699!^
700 ad_fc(i,k-1)=ad_fc(i,k-1)-ad_cff
701 ad_fc(i,k )=ad_fc(i,k )+ad_cff
702 ad_cff=0.0_r8
703 END DO
704 END DO
705# ifdef UV_SADVECTION
706!
707! Apply spline code to BASIC STATE v-momentum which should be in
708! units of m/s. CF will be used by the tangent linear spline code.
709!
710 cff1=9.0_r8/16.0_r8
711 cff2=1.0_r8/16.0_r8
712 DO k=1,n(ng)
713 DO i=istr,iend
714 dc(i,k)=(cff1*(hz(i,j ,k)+ &
715 & hz(i,j-1,k))- &
716 & cff2*(hz(i,j+1,k)+ &
717 & hz(i,j-2,k)))
718 END DO
719 END DO
720 DO i=istr,iend
721 fc(i,0)=0.0_r8
722 cf(i,0)=0.0_r8
723 END DO
724 DO k=1,n(ng)-1
725 DO i=istr,iend
726 cff=1.0_r8/(2.0_r8*dc(i,k+1)+dc(i,k)*(2.0_r8-fc(i,k-1)))
727 fc(i,k)=cff*dc(i,k+1)
728 cf(i,k)=cff*(6.0_r8*(v(i,j,k+1,nrhs)- &
729# ifdef WEC_MELLOR
730 & v_stokes(i,j,k )+ &
731 & v_stokes(i,j,k+1)- &
732# endif
733 & v(i,j,k ,nrhs))- &
734 & dc(i,k)*cf(i,k-1))
735 END DO
736 END DO
737 DO i=istr,iend
738 cf(i,n(ng))=0.0_r8
739 END DO
740 DO k=n(ng)-1,1,-1
741 DO i=istr,iend
742 cf(i,k)=cf(i,k)-fc(i,k)*cf(i,k+1)
743 END DO
744 END DO
745!
746! Compute spline-interpolated, vertical advective v-momentum flux.
747!
748 DO i=istr,iend
749!^ tl_FC(i,N(ng))=0.0_r8
750!^
751 ad_fc(i,n(ng))=0.0_r8
752!^ tl_FC(i,0)=0.0_r8
753!^
754 ad_fc(i,0)=0.0_r8
755 END DO
756 cff3=1.0_r8/3.0_r8
757 cff4=1.0_r8/6.0_r8
758 DO k=1,n(ng)-1
759 DO i=istr,iend
760!^ tl_FC(i,k)=(cff1*(tl_W(i,j ,k)+ &
761!^ & tl_W(i,j-1,k))- &
762!^ & cff2*(tl_W(i,j+1,k)+ &
763!^ & tl_W(i,j-2,k)))* &
764!^ & (v(i,j,k,nrhs)+ &
765# ifdef WEC_MELLOR
766!^ & v_stokes(i,j,k)+ &
767# endif
768!^ & DC(i,k)*(cff3*CF(i,k )+ &
769!^ & cff4*CF(i,k-1)))+ &
770!^ & (cff1*(W(i,j ,k)+ &
771!^ & W(i,j-1,k))- &
772!^ & cff2*(W(i,j+1,k)+ &
773!^ & W(i,j-2,k)))* &
774!^ & (tl_v(i,j,k,nrhs)+ &
775# ifdef WEC_MELLOR
776!^ & tl_v_stokes(i,j,k)+ &
777# endif
778!^ & DC(i,k)*(cff3*tl_CF(i,k )+ &
779!^ & cff4*tl_CF(i,k-1))+ &
780!^ & tl_DC(i,k)*(cff3*CF(i,k )+ &
781!^ & cff4*CF(i,k-1)))
782!^
783 adfac1=(cff1*(w(i,j ,k)+ &
784 & w(i,j-1,k))- &
785 & cff2*(w(i,j+1,k)+ &
786 & w(i,j-2,k)))*ad_fc(i,k)
787 adfac2=adfac1*dc(i,k)
788 adfac3=(v(i,j,k,nrhs)+ &
789# ifdef WEC_MELLOR
790 & v_stokes(i,j,k)+ &
791# endif
792 & dc(i,k)*(cff3*cf(i,k )+ &
793 & cff4*cf(i,k-1)))*ad_fc(i,k)
794 adfac4=adfac3*cff1
795 adfac5=adfac3*cff2
796 ad_dc(i,k)=ad_dc(i,k)+(cff3*cf(i,k )+ &
797 cff4*cf(i,k-1))*adfac1
798 ad_cf(i,k-1)=ad_cf(i,k-1)+cff4*adfac2
799 ad_cf(i,k )=ad_cf(i,k )+cff3*adfac2
800 ad_v(i,j,k,nrhs)=ad_v(i,j,k,nrhs)+adfac1
801# ifdef WEC_MELLOR
802 ad_v_stokes(i,j,k)=ad_v_stokes(i,j,k)+adfac1
803# endif
804 ad_w(i,j-2,k)=ad_w(i,j-2,k)-adfac5
805 ad_w(i,j-1,k)=ad_w(i,j-1,k)+adfac4
806 ad_w(i,j ,k)=ad_w(i,j ,k)+adfac4
807 ad_w(i,j+1,k)=ad_w(i,j+1,k)-adfac5
808 ad_fc(i,k)=0.0_r8
809 END DO
810 END DO
811!
812! Construct adjoint conservative parabolic splines for the vertical
813! derivatives "tl_CF" of v-momentum.
814!
815 DO k=1,n(ng)-1 ! adjoint back substitution
816 DO i=istr,iend
817!^ tl_CF(i,k)=tl_CF(i,k)-FC(i,k)*tl_CF(i,k+1)
818!^
819 ad_cf(i,k+1)=ad_cf(i,k+1)-fc(i,k)*ad_cf(i,k)
820 END DO
821 END DO
822 DO i=istr,iend
823!^ tl_CF(i,N(ng))=0.0_r8
824!^
825 ad_cf(i,n(ng))=0.0_r8
826 END DO ! adjoint LU decomposition
827 DO k=n(ng)-1,1,-1 ! and forward substitution
828 DO i=istr,iend
829 cff=1.0_r8/(2.0_r8*dc(i,k+1)+dc(i,k)*(2.0_r8-fc(i,k-1)))
830!^ tl_CF(i,k)=cff*(6.0_r8*(tl_v(i,j,k+1,nrhs)- &
831# ifdef WEC_MELLOR
832!^ & tl_v_stokes(i,j,k )+ &
833!^ & tl_v_stokes(i,j,k+1)- &
834# endif
835!^ & tl_v(i,j,k ,nrhs))- &
836!^ & (tl_DC(i,k)*CF(i,k-1)+ &
837!^ & 2.0_r8*(tl_DC(i,k )+ &
838!^ & tl_DC(i,k+1))*CF(i,k)+ &
839!^ & tl_DC(i,k+1)*CF(i,k+1))- &
840!^ & DC(i,k)*tl_CF(i,k-1))
841!^
842 adfac=cff*ad_cf(i,k)
843 adfac1=adfac*6.0_r8
844 ad_cf(i,k-1)=ad_cf(i,k-1)-dc(i,k)*adfac
845 ad_dc(i,k )=ad_dc(i,k )- &
846 & (cf(i,k-1)+2.0_r8*cf(i,k))*adfac
847 ad_dc(i,k+1)=ad_dc(i,k+1)- &
848 & (cf(i,k+1)+2.0_r8*cf(i,k))*adfac
849 ad_v(i,j,k ,nrhs)=ad_v(i,j,k ,nrhs)-adfac1
850 ad_v(i,j,k+1,nrhs)=ad_v(i,j,k+1,nrhs)+adfac1
851# ifdef WEC_MELLOR
852 ad_v_stokes(i,j,k )=ad_v_stokes(i,j,k )-adfac1
853 ad_v_stokes(i,j,k+1)=ad_v_stokes(i,j,k+1)+adfac1
854# endif
855 ad_cf(i,k)=0.0_r8
856 END DO
857 END DO
858 DO i=istr,iend
859!^ tl_CF(i,0)=0.0_r8
860!^
861 ad_cf(i,0)=0.0_r8
862 END DO
863 cff1=9.0_r8/16.0_r8
864 cff2=1.0_r8/16.0_r8
865 DO k=1,n(ng) ! adjoint triadiagonal coefficients
866 DO i=istr,iend
867!^ tl_DC(i,k)=(cff1*(tl_Hz(i,j ,k)+ &
868!^ & tl_Hz(i,j-1,k))- &
869!^ & cff2*(tl_Hz(i,j+1,k)+ &
870!^ & tl_Hz(i,j-2,k)))
871!^
872 adfac1=cff1*ad_dc(i,k)
873 adfac2=cff2*ad_dc(i,k)
874 ad_hz(i,j-2,k)=ad_hz(i,j-2,k)-adfac2
875 ad_hz(i,j-1,k)=ad_hz(i,j-1,k)+adfac1
876 ad_hz(i,j ,k)=ad_hz(i,j ,k)+adfac1
877 ad_hz(i,j+1,k)=ad_hz(i,j+1,k)-adfac2
878 ad_dc(i,k)=0.0
879 END DO
880 END DO
881# elif defined UV_C2ADVECTION
882!
883! Second-order, central differences vertical v-momentum advection.
884!
885 DO i=istr,iend
886!^ tl_FC(i,0)=0.0_r8
887!^
888 ad_fc(i,0)=0.0_r8
889!^ tl_FC(i,N(ng))=0.0_r8
890!^
891 ad_fc(i,n(ng))=0.0_r8
892 END DO
893 DO k=1,n(ng)-1
894 DO i=istr,iend
895!^ tl_FC(i,k)=0.25_r8*((tl_v(i,j,k ,nrhs)+ &
896# ifdef WEC_MELLOR
897!^ & tl_v_stokes(i,j,k )+ &
898!^ & tl_v_stokes(i,j,k+1)+ &
899# endif
900!^ & tl_v(i,j,k+1,nrhs))* &
901!^ & (W(i,j ,k)+ &
902!^ & W(i,j-1,k))+ &
903!^ & (v(i,j,k ,nrhs)+ &
904# ifdef WEC_MELLOR
905!^ & v_stokes(i,j,k )+ &
906!^ & v_stokes(i,j,k+1)+ &
907# endif
908!^ & v(i,j,k+1,nrhs))* &
909!^ & (tl_W(i,j ,k)+ &
910!^ & tl_W(i,j-1,k)))
911!^
912 adfac=0.25_r8*ad_fc(i,k)
913 adfac1=adfac*(v(i,j,k ,nrhs)+ &
914# ifdef WEC_MELLOR
915 & v_stokes(i,j,k )+ &
916 & v_stokes(i,j,k+1)+ &
917# endif
918 & v(i,j,k+1,nrhs))
919 adfac2=adfac*(w(i,j ,k)+ &
920 & w(i,j-1,k))
921 ad_w(i,j-1,k)=ad_w(i,j-1,k)+adfac1
922 ad_w(i,j ,k)=ad_w(i,j ,k)+adfac1
923 ad_v(i,j,k ,nrhs)=ad_v(i,j,k ,nrhs)+adfac2
924 ad_v(i,j,k+1,nrhs)=ad_v(i,j,k+1,nrhs)+adfac2
925# ifdef WEC_MELLOR
926 ad_v_stokes(i,j,k )=ad_v_stokes(i,j,k )+adfac2
927 ad_v_stokes(i,j,k+1)=ad_v_stokes(i,j,k+1)+adfac2
928# endif
929 ad_fc(i,k)=0.0_r8
930 END DO
931 END DO
932# elif defined UV_C4ADVECTION
933!
934! Fourth-order, central differences vertical v-momentum advection.
935!
936 cff1=9.0_r8/32.0_r8
937 cff2=1.0_r8/32.0_r8
938 DO i=istr,iend
939!^ tl_FC(i,0)=0.0_r8
940!^
941 ad_fc(i,0)=0.0_r8
942!^ tl_FC(i,1)=(cff1*(tl_v(i,j,1,nrhs)+ &
943# ifdef WEC_MELLOR
944!^ & tl_v_stokes(i,j,1)+ &
945!^ & tl_v_stokes(i,j,2)+ &
946# endif
947!^ & tl_v(i,j,2,nrhs))- &
948!^ & cff2*(tl_v(i,j,1,nrhs)+ &
949# ifdef WEC_MELLOR
950!^ & tl_v_stokes(i,j,1)+ &
951!^ & tl_v_stokes(i,j,3)+ &
952# endif
953!^ & tl_v(i,j,3,nrhs)))* &
954!^ & (W(i,j ,1)+ &
955!^ & W(i,j-1,1))+ &
956!^ & (cff1*(v(i,j,1,nrhs)+ &
957# ifdef WEC_MELLOR
958!^ & v_stokes(i,j,1)+ &
959!^ & v_stokes(i,j,2)+ &
960# endif
961!^ & v(i,j,2,nrhs))- &
962!^ & cff2*(v(i,j,1,nrhs)+ &
963# ifdef WEC_MELLOR
964!^ & v_stokes(i,j,1)+ &
965!^ & v_stokes(i,j,3)+ &
966# endif
967!^ & v(i,j,3,nrhs)))* &
968!^ & (tl_W(i,j ,1)+ &
969!^ & tl_W(i,j-1,1))
970!^
971 adfac=(w(i,j ,1)+ &
972 & w(i,j-1,1))*ad_fc(i,1)
973 adfac1=adfac*cff1
974 adfac2=adfac*cff2
975 adfac3=(cff1*(v(i,j,1,nrhs)+ &
976# ifdef WEC_MELLOR
977 & v_stokes(i,j,1)+ &
978 & v_stokes(i,j,2)+ &
979# endif
980 & v(i,j,2,nrhs))- &
981 & cff2*(v(i,j,1,nrhs)+ &
982# ifdef WEC_MELLOR
983 & v_stokes(i,j,1)+ &
984 & v_stokes(i,j,3)+ &
985# endif
986 & v(i,j,3,nrhs)))*ad_fc(i,1)
987 ad_w(i,j-1,1)=ad_w(i,j-1,1)+adfac3
988 ad_w(i,j ,1)=ad_w(i,j ,1)+adfac3
989 ad_v(i,j,1,nrhs)=ad_v(i,j,1,nrhs)+adfac1-adfac2
990 ad_v(i,j,2,nrhs)=ad_v(i,j,2,nrhs)+adfac1
991 ad_v(i,j,3,nrhs)=ad_v(i,j,3,nrhs)-adfac2
992# ifdef WEC_MELLOR
993 ad_v_stokes(i,j,1)=ad_v_stokes(i,j,1)+adfac1-adfac2
994 ad_v_stokes(i,j,2)=ad_v_stokes(i,j,2)+adfac1
995 ad_v_stokes(i,j,3)=ad_v_stokes(i,j,3)-adfac2
996# endif
997 ad_fc(i,1)=0.0_r8
998!^ tl_FC(i,N(ng)-1)=(cff1*(tl_v(i,j,N(ng)-1,nrhs)+ &
999# ifdef WEC_MELLOR
1000!^ & tl_v_stokes(i,j,N(ng)-1)+ &
1001!^ & tl_v_stokes(i,j,N(ng) )+ &
1002# endif
1003!^ & tl_v(i,j,N(ng) ,nrhs))- &
1004!^ & cff2*(tl_v(i,j,N(ng)-2,nrhs)+ &
1005# ifdef WEC_MELLOR
1006!^ & tl_v_stokes(i,j,N(ng)-2)+ &
1007!^ & tl_v_stokes(i,j,N(ng) )+ &
1008# endif
1009!^ & tl_v(i,j,N(ng) ,nrhs)))* &
1010!^ & (W(i,j ,N(ng)-1)+ &
1011!^ & W(i,j-1,N(ng)-1))+ &
1012!^ & (cff1*(v(i,j,N(ng)-1,nrhs)+ &
1013# ifdef WEC_MELLOR
1014!^ & v_stokes(i,j,N(ng)-1)+ &
1015!^ & v_stokes(i,j,N(ng) )+ &
1016# endif
1017!^ & v(i,j,N(ng) ,nrhs))- &
1018!^ & cff2*(v(i,j,N(ng)-2,nrhs)+ &
1019# ifdef WEC_MELLOR
1020!^ & v_stokes(i,j,N(ng)-2)+ &
1021!^ & v_stokes(i,j,N(ng) )+ &
1022# endif
1023!^ & v(i,j,N(ng) ,nrhs)))* &
1024!^ & (tl_W(i,j ,N(ng)-1)+ &
1025!^ & tl_W(i,j-1,N(ng)-1))
1026!^
1027 adfac=(w(i,j ,n(ng)-1)+ &
1028 & w(i,j-1,n(ng)-1))*ad_fc(i,n(ng)-1)
1029 adfac1=adfac*cff1
1030 adfac2=adfac*cff2
1031 adfac3=(cff1*(v(i,j,n(ng)-1,nrhs)+ &
1032# ifdef WEC_MELLOR
1033 & v_stokes(i,j,n(ng)-1)+ &
1034 & v_stokes(i,j,n(ng) )+ &
1035# endif
1036 & v(i,j,n(ng) ,nrhs))- &
1037 & cff2*(v(i,j,n(ng)-2,nrhs)+ &
1038# ifdef WEC_MELLOR
1039 & v_stokes(i,j,n(ng)-2)+ &
1040 & v_stokes(i,j,n(ng) )+ &
1041# endif
1042 & v(i,j,n(ng) ,nrhs)))*ad_fc(i,n(ng)-1)
1043 ad_w(i,j-1,n(ng)-1)=ad_w(i,j-1,n(ng)-1)+adfac3
1044 ad_w(i,j ,n(ng)-1)=ad_w(i,j ,n(ng)-1)+adfac3
1045 ad_v(i,j,n(ng)-2,nrhs)=ad_v(i,j,n(ng)-2,nrhs)-adfac2
1046 ad_v(i,j,n(ng)-1,nrhs)=ad_v(i,j,n(ng)-1,nrhs)+adfac1
1047 ad_v(i,j,n(ng) ,nrhs)=ad_v(i,j,n(ng) ,nrhs)+adfac1-adfac2
1048# ifdef WEC_MELLOR
1049 ad_v_stokes(i,j,n(ng)-2)=ad_v_stokes(i,j,n(ng)-2)-adfac2
1050 ad_v_stokes(i,j,n(ng)-1)=ad_v_stokes(i,j,n(ng)-1)+adfac1
1051 ad_v_stokes(i,j,n(ng) )=ad_v_stokes(i,j,n(ng) )+adfac1- &
1052 & adfac2
1053# endif
1054 ad_fc(i,n(ng)-1)=0.0_r8
1055!^ tl_FC(i,N(ng))=0.0_r8
1056!^
1057 ad_fc(i,n(ng))=0.0_r8
1058 END DO
1059 DO k=2,n(ng)-2
1060 DO i=istr,iend
1061!^ tl_FC(i,k)=(cff1*(tl_v(i,j,k ,nrhs)+ &
1062# ifdef WEC_MELLOR
1063!^ & tl_v_stokes(i,j,k )+ &
1064!^ & tl_v_stokes(i,j,k+1)+ &
1065# endif
1066!^ & tl_v(i,j,k+1,nrhs))- &
1067!^ & cff2*(tl_v(i,j,k-1,nrhs)+ &
1068# ifdef WEC_MELLOR
1069!^ & tl_v_stokes(i,j,k-1)+ &
1070!^ & tl_v_stokes(i,j,k+2)+ &
1071# endif
1072!^ & tl_v(i,j,k+2,nrhs)))* &
1073!^ & (W(i,j ,k)+ &
1074!^ & W(i,j-1,k))+ &
1075!^ & (cff1*(v(i,j,k ,nrhs)+ &
1076# ifdef WEC_MELLOR
1077!^ & v_stokes(i,j,k )+ &
1078!^ & v_stokes(i,j,k+1)+ &
1079# endif
1080!^ & v(i,j,k+1,nrhs))- &
1081!^ & cff2*(v(i,j,k-1,nrhs)+ &
1082# ifdef WEC_MELLOR
1083!^ & v_stokes(i,j,k-1)+ &
1084!^ & v_stokes(i,j,k+2)+ &
1085# endif
1086!^ & v(i,j,k+2,nrhs)))* &
1087!^ & (tl_W(i,j ,k)+ &
1088!^ & tl_W(i,j-1,k))
1089!^
1090 adfac=(w(i,j ,k)+ &
1091 & w(i,j-1,k))*ad_fc(i,k)
1092 adfac1=adfac*cff1
1093 adfac2=adfac*cff2
1094 adfac3=(cff1*(v(i,j,k ,nrhs)+ &
1095# ifdef WEC_MELLOR
1096 & v_stokes(i,j,k )+ &
1097 & v_stokes(i,j,k+1)+ &
1098# endif
1099 & v(i,j,k+1,nrhs))- &
1100 & cff2*(v(i,j,k-1,nrhs)+ &
1101# ifdef WEC_MELLOR
1102 & v_stokes(i,j,k-1)+ &
1103 & v_stokes(i,j,k+2)+ &
1104# endif
1105 & v(i,j,k+2,nrhs)))*ad_fc(i,k)
1106 ad_w(i,j-1,k)=ad_w(i,j-1,k)+adfac3
1107 ad_w(i,j ,k)=ad_w(i,j ,k)+adfac3
1108 ad_v(i,j,k-1,nrhs)=ad_v(i,j,k-1,nrhs)-adfac2
1109 ad_v(i,j,k ,nrhs)=ad_v(i,j,k ,nrhs)+adfac1
1110 ad_v(i,j,k+1,nrhs)=ad_v(i,j,k+1,nrhs)+adfac1
1111 ad_v(i,j,k+2,nrhs)=ad_v(i,j,k+2,nrhs)-adfac2
1112# ifdef WEC_MELLOR
1113 ad_v_stokes(i,j,k-1)=ad_v_stokes(i,j,k-1)-adfac2
1114 ad_v_stokes(i,j,k )=ad_v_stokes(i,j,k )+adfac1
1115 ad_v_stokes(i,j,k+1)=ad_v_stokes(i,j,k+1)+adfac1
1116 ad_v_stokes(i,j,k+2)=ad_v_stokes(i,j,k+2)-adfac2
1117# endif
1118 ad_fc(i,k)=0.0_r8
1119 END DO
1120 END DO
1121# else
1122!
1123! Fourth-order, central differences vertical v-momentum advection.
1124!
1125 cff1=9.0_r8/16.0_r8
1126 cff2=1.0_r8/16.0_r8
1127 DO i=istr,iend
1128!^ tl_FC(i,0)=0.0_r8
1129!^
1130 ad_fc(i,0)=0.0_r8
1131!^ tl_FC(i,1)=(cff1*(tl_v(i,j,1,nrhs)+ &
1132# ifdef WEC_MELLOR
1133!^ & tl_v_stokes(i,j,1)+ &
1134!^ & tl_v_stokes(i,j,2)+ &
1135# endif
1136!^ & tl_v(i,j,2,nrhs))- &
1137!^ & cff2*(tl_v(i,j,1,nrhs)+ &
1138# ifdef WEC_MELLOR
1139!^ & tl_v_stokes(i,j,1)+ &
1140!^ & tl_v_stokes(i,j,3)+ &
1141# endif
1142!^ & tl_v(i,j,3,nrhs)))* &
1143!^ & (cff1*(W(i,j ,1)+ &
1144!^ & W(i,j-1,1))- &
1145!^ & cff2*(W(i,j+1,1)+ &
1146!^ & W(i,j-2,1)))+ &
1147!^ & (cff1*(v(i,j,1,nrhs)+ &
1148# ifdef WEC_MELLOR
1149!^ & v_stokes(i,j,1)+ &
1150!^ & v_stokes(i,j,2)+ &
1151# endif
1152!^ & v(i,j,2,nrhs))- &
1153!^ & cff2*(v(i,j,1,nrhs)+ &
1154# ifdef WEC_MELLOR
1155!^ & v_stokes(i,j,1)+ &
1156!^ & v_stokes(i,j,3)+ &
1157# endif
1158!^ & v(i,j,3,nrhs)))* &
1159!^ & (cff1*(tl_W(i,j ,1)+ &
1160!^ & tl_W(i,j-1,1))- &
1161!^ & cff2*(tl_W(i,j+1,1)+ &
1162!^ & tl_W(i,j-2,1)))
1163!^
1164 adfac=(cff1*(w(i,j ,1)+ &
1165 & w(i,j-1,1))- &
1166 & cff2*(w(i,j+1,1)+ &
1167 & w(i,j-2,1)))*ad_fc(i,1)
1168 adfac1=adfac*cff1
1169 adfac2=adfac*cff2
1170 adfac=(cff1*(v(i,j,1,nrhs)+ &
1171# ifdef WEC_MELLOR
1172 & v_stokes(i,j,1)+ &
1173 & v_stokes(i,j,2)+ &
1174# endif
1175 & v(i,j,2,nrhs))- &
1176 & cff2*(v(i,j,1,nrhs)+ &
1177# ifdef WEC_MELLOR
1178 & v_stokes(i,j,1)+ &
1179 & v_stokes(i,j,3)+ &
1180# endif
1181 & v(i,j,3,nrhs)))*ad_fc(i,1)
1182 adfac3=adfac*cff1
1183 adfac4=adfac*cff2
1184 ad_w(i,j-2,1)=ad_w(i,j-2,1)-adfac4
1185 ad_w(i,j-1,1)=ad_w(i,j-1,1)+adfac3
1186 ad_w(i,j ,1)=ad_w(i,j ,1)+adfac3
1187 ad_w(i,j+1,1)=ad_w(i,j+1,1)-adfac4
1188 ad_v(i,j,1,nrhs)=ad_v(i,j,1,nrhs)+adfac1-adfac2
1189 ad_v(i,j,2,nrhs)=ad_v(i,j,2,nrhs)+adfac1
1190 ad_v(i,j,3,nrhs)=ad_v(i,j,3,nrhs)-adfac2
1191# ifdef WEC_MELLOR
1192 ad_v_stokes(i,j,1)=ad_v_stokes(i,j,1)+adfac1-adfac2
1193 ad_v_stokes(i,j,2)=ad_v_stokes(i,j,2)+adfac1
1194 ad_v_stokes(i,j,3)=ad_v_stokes(i,j,3)-adfac2
1195# endif
1196 ad_fc(i,1)=0.0_r8
1197!^ tl_FC(i,N(ng)-1)=(cff1*(tl_v(i,j,N(ng)-1,nrhs)+ &
1198# ifdef WEC_MELLOR
1199!^ & tl_v_stokes(i,j,N(ng)-1)+ &
1200!^ & tl_v_stokes(i,j,N(ng) )+ &
1201# endif
1202!^ & tl_v(i,j,N(ng) ,nrhs))- &
1203!^ & cff2*(tl_v(i,j,N(ng)-2,nrhs)+ &
1204# ifdef WEC_MELLOR
1205!^ & tl_v_stokes(i,j,N(ng)-2)+ &
1206!^ & tl_v_stokes(i,j,N(ng) )+ &
1207# endif
1208!^ & tl_v(i,j,N(ng) ,nrhs)))* &
1209!^ & (cff1*(W(i,j ,N(ng)-1)+ &
1210!^ & W(i,j-1,N(ng)-1))- &
1211!^ & cff2*(W(i,j+1,N(ng)-1)+ &
1212!^ & W(i,j-2,N(ng)-1)))+ &
1213!^ & (cff1*(v(i,j,N(ng)-1,nrhs)+ &
1214# ifdef WEC_MELLOR
1215!^ & v_stokes(i,j,N(ng)-1)+ &
1216!^ & v_stokes(i,j,N(ng) )+ &
1217# endif
1218!^ & v(i,j,N(ng) ,nrhs))- &
1219!^ & cff2*(v(i,j,N(ng)-2,nrhs)+ &
1220# ifdef WEC_MELLOR
1221!^ & v_stokes(i,j,N(ng)-2)+ &
1222!^ & v_stokes(i,j,N(ng) )+ &
1223# endif
1224!^ & v(i,j,N(ng) ,nrhs)))* &
1225!^ & (cff1*(tl_W(i,j ,N(ng)-1)+ &
1226!^ & tl_W(i,j-1,N(ng)-1))- &
1227!^ & cff2*(tl_W(i,j+1,N(ng)-1)+ &
1228!^ & tl_W(i,j-2,N(ng)-1)))
1229!^
1230 adfac=(cff1*(w(i,j ,n(ng)-1)+ &
1231 & w(i,j-1,n(ng)-1))- &
1232 & cff2*(w(i,j+1,n(ng)-1)+ &
1233 & w(i,j-2,n(ng)-1)))*ad_fc(i,n(ng)-1)
1234 adfac1=adfac*cff1
1235 adfac2=adfac*cff2
1236 adfac=(cff1*(v(i,j,n(ng)-1,nrhs)+ &
1237# ifdef WEC_MELLOR
1238 & v_stokes(i,j,n(ng)-1)+ &
1239 & v_stokes(i,j,n(ng) )+ &
1240# endif
1241 & v(i,j,n(ng) ,nrhs))- &
1242 & cff2*(v(i,j,n(ng)-2,nrhs)+ &
1243# ifdef WEC_MELLOR
1244 & v_stokes(i,j,n(ng)-2)+ &
1245 & v_stokes(i,j,n(ng) )+ &
1246# endif
1247 & v(i,j,n(ng) ,nrhs)))*ad_fc(i,n(ng)-1)
1248 adfac3=adfac*cff1
1249 adfac4=adfac*cff2
1250 ad_w(i,j-2,n(ng)-1)=ad_w(i,j-2,n(ng)-1)-adfac4
1251 ad_w(i,j-1,n(ng)-1)=ad_w(i,j-1,n(ng)-1)+adfac3
1252 ad_w(i,j ,n(ng)-1)=ad_w(i,j ,n(ng)-1)+adfac3
1253 ad_w(i,j+1,n(ng)-1)=ad_w(i,j+1,n(ng)-1)-adfac4
1254 ad_v(i,j,n(ng)-2,nrhs)=ad_v(i,j,n(ng)-2,nrhs)-adfac2
1255 ad_v(i,j,n(ng)-1,nrhs)=ad_v(i,j,n(ng)-1,nrhs)+adfac1
1256 ad_v(i,j,n(ng) ,nrhs)=ad_v(i,j,n(ng) ,nrhs)+adfac1-adfac2
1257# ifdef WEC_MELLOR
1258 ad_v_stokes(i,j,n(ng)-2)=ad_v_stokes(i,j,n(ng)-2)-adfac2
1259 ad_v_stokes(i,j,n(ng)-1)=ad_v_stokes(i,j,n(ng)-1)+adfac1
1260 ad_v_stokes(i,j,n(ng) )=ad_v_stokes(i,j,n(ng) )+adfac1- &
1261 & adfac2
1262# endif
1263 ad_fc(i,n(ng)-1)=0.0_r8
1264!^ tl_FC(i,N(ng))=0.0_r8
1265!^
1266 ad_fc(i,n(ng))=0.0_r8
1267 END DO
1268 DO k=2,n(ng)-2
1269 DO i=istr,iend
1270!^ tl_FC(i,k)=(cff1*(tl_v(i,j,k ,nrhs)+ &
1271# ifdef WEC_MELLOR
1272!^ & tl_v_stokes(i,j,k )+ &
1273!^ & tl_v_stokes(i,j,k+1)+ &
1274# endif
1275!^ & tl_v(i,j,k+1,nrhs))- &
1276!^ & cff2*(tl_v(i,j,k-1,nrhs)+ &
1277# ifdef WEC_MELLOR
1278!^ & tl_v_stokes(i,j,k-1)+ &
1279!^ & tl_v_stokes(i,j,k+2)+ &
1280# endif
1281!^ & tl_v(i,j,k+2,nrhs)))* &
1282!^ & (cff1*(W(i,j ,k)+ &
1283!^ & W(i,j-1,k))- &
1284!^ & cff2*(W(i,j+1,k)+ &
1285!^ & W(i,j-2,k)))+ &
1286!^ & (cff1*(v(i,j,k ,nrhs)+ &
1287# ifdef WEC_MELLOR
1288!^ & v_stokes(i,j,k )+ &
1289!^ & v_stokes(i,j,k+1)+ &
1290# endif
1291!^ & v(i,j,k+1,nrhs))- &
1292!^ & cff2*(v(i,j,k-1,nrhs)+ &
1293# ifdef WEC_MELLOR
1294!^ & v_stokes(i,j,k-1)+ &
1295!^ & v_stokes(i,j,k+2)+ &
1296# endif
1297!^ & v(i,j,k+2,nrhs)))* &
1298!^ & (cff1*(tl_W(i,j ,k)+ &
1299!^ & tl_W(i,j-1,k))- &
1300!^ & cff2*(tl_W(i,j+1,k)+ &
1301!^ & tl_W(i,j-2,k)))
1302!^
1303 adfac=(cff1*(w(i,j ,k)+ &
1304 & w(i,j-1,k))- &
1305 & cff2*(w(i,j+1,k)+ &
1306 & w(i,j-2,k)))*ad_fc(i,k)
1307 adfac1=adfac*cff1
1308 adfac2=adfac*cff2
1309 adfac=(cff1*(v(i,j,k ,nrhs)+ &
1310# ifdef WEC_MELLOR
1311 & v_stokes(i,j,k )+ &
1312 & v_stokes(i,j,k+1)+ &
1313# endif
1314 & v(i,j,k+1,nrhs))- &
1315 & cff2*(v(i,j,k-1,nrhs)+ &
1316# ifdef WEC_MELLOR
1317 & v_stokes(i,j,k-1)+ &
1318 & v_stokes(i,j,k+2)+ &
1319# endif
1320 & v(i,j,k+2,nrhs)))*ad_fc(i,k)
1321 adfac3=adfac*cff1
1322 adfac4=adfac*cff2
1323 ad_w(i,j-2,k)=ad_w(i,j-2,k)-adfac4
1324 ad_w(i,j-1,k)=ad_w(i,j-1,k)+adfac3
1325 ad_w(i,j ,k)=ad_w(i,j ,k)+adfac3
1326 ad_w(i,j+1,k)=ad_w(i,j+1,k)-adfac4
1327 ad_v(i,j,k-1,nrhs)=ad_v(i,j,k-1,nrhs)-adfac2
1328 ad_v(i,j,k ,nrhs)=ad_v(i,j,k ,nrhs)+adfac1
1329 ad_v(i,j,k+1,nrhs)=ad_v(i,j,k+1,nrhs)+adfac1
1330 ad_v(i,j,k+2,nrhs)=ad_v(i,j,k+2,nrhs)-adfac2
1331# ifdef WEC_MELLOR
1332 ad_v_stokes(i,j,k-1)=ad_v_stokes(i,j,k-1)-adfac2
1333 ad_v_stokes(i,j,k )=ad_v_stokes(i,j,k )+adfac1
1334 ad_v_stokes(i,j,k+1)=ad_v_stokes(i,j,k+1)+adfac1
1335 ad_v_stokes(i,j,k+2)=ad_v_stokes(i,j,k+2)-adfac2
1336# endif
1337 ad_fc(i,k)=0.0_r8
1338 END DO
1339 END DO
1340# endif
1341 END IF
1342!
1343!-----------------------------------------------------------------------
1344! Add in adjoint vertical advection, U-momentum.
1345!-----------------------------------------------------------------------
1346!
1347 DO k=1,n(ng)
1348 DO i=istru,iend
1349# ifdef DIAGNOSTICS_UV
1350!! DiaRU(i,j,k,nrhs,M3vadv)=-cff
1351# endif
1352!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)-tl_cff
1353!^
1354 ad_cff=ad_cff-ad_ru(i,j,k,nrhs)
1355!^ tl_cff=tl_FC(i,k)-tl_FC(i,k-1)
1356!^
1357 ad_fc(i,k-1)=ad_fc(i,k-1)-ad_cff
1358 ad_fc(i,k )=ad_fc(i,k )+ad_cff
1359 ad_cff=0.0_r8
1360 END DO
1361 END DO
1362# ifdef UV_SADVECTION
1363!
1364! Apply spline code to BASIC STATE u-momentum which should be in
1365! units of m/s. CF will be used by the tangent linear spline code.
1366!
1367 cff1=9.0_r8/16.0_r8
1368 cff2=1.0_r8/16.0_r8
1369 DO k=1,n(ng)
1370 DO i=istru,iend
1371 dc(i,k)=cff1*(hz(i ,j,k)+ &
1372 & hz(i-1,j,k))- &
1373 & cff2*(hz(i+1,j,k)+ &
1374 & hz(i-2,j,k))
1375 END DO
1376 END DO
1377 DO i=istru,iend
1378 fc(i,0)=0.0_r8
1379 cf(i,0)=0.0_r8
1380 END DO
1381 DO k=1,n(ng)-1
1382 DO i=istru,iend
1383 cff=1.0_r8/(2.0_r8*dc(i,k+1)+dc(i,k)*(2.0_r8-fc(i,k-1)))
1384 fc(i,k)=cff*dc(i,k+1)
1385 cf(i,k)=cff*(6.0_r8*(u(i,j,k+1,nrhs)- &
1386# ifdef WEC_MELLOR
1387 & u_stokes(i,j,k )+ &
1388 & u_stokes(i,j,k+1)- &
1389# endif
1390 & u(i,j,k ,nrhs))- &
1391 & dc(i,k)*cf(i,k-1))
1392 END DO
1393 END DO
1394 DO i=istru,iend
1395 cf(i,n(ng))=0.0_r8
1396 END DO
1397 DO k=n(ng)-1,1,-1
1398 DO i=istru,iend
1399 cf(i,k)=cf(i,k)-fc(i,k)*cf(i,k+1)
1400 END DO
1401 END DO
1402!
1403! Compute spline-interpolated, vertical advective u-momentum flux.
1404!
1405 DO i=istru,iend
1406!^ tl_FC(i,N(ng))=0.0_r8
1407!^
1408 ad_fc(i,n(ng))=0.0_r8
1409!^ tl_FC(i,0)=0.0_r8
1410!^
1411 ad_fc(i,0)=0.0_r8
1412 END DO
1413 cff3=1.0_r8/3.0_r8
1414 cff4=1.0_r8/6.0_r8
1415 DO k=1,n(ng)-1
1416 DO i=istru,iend
1417!^ tl_FC(i,k)=(cff1*(tl_W(i ,j,k)+ &
1418!^ & tl_W(i-1,j,k))- &
1419!^ & cff2*(tl_W(i+1,j,k)+ &
1420!^ & tl_W(i-2,j,k)))* &
1421!^ & (u(i,j,k,nrhs)+ &
1422# ifdef WEC_MELLOR
1423!^ & u_stokes(i,j,k)+ &
1424# endif
1425!^ & DC(i,k)*(cff3*CF(i,k )+ &
1426!^ & cff4*CF(i,k-1)))+ &
1427!^ & (cff1*(W(i ,j,k)+ &
1428!^ & W(i-1,j,k))- &
1429!^ & cff2*(W(i+1,j,k)+ &
1430!^ & W(i-2,j,k)))* &
1431!^ & (tl_u(i,j,k,nrhs)+ &
1432# ifdef WEC_MELLOR
1433!^ & tl_u_stokes(i,j,k)+ &
1434# endif
1435!^ & DC(i,k)*(cff3*tl_CF(i,k )+ &
1436!^ & cff4*tl_CF(i,k-1))+ &
1437!^ & tl_DC(i,k)*(cff3*CF(i,k )+ &
1438!^ & cff4*CF(i,k-1)))
1439!^
1440 adfac1=(cff1*(w(i ,j,k)+ &
1441 & w(i-1,j,k))- &
1442 & cff2*(w(i+1,j,k)+ &
1443 & w(i-2,j,k)))*ad_fc(i,k)
1444 adfac2=adfac1*dc(i,k)
1445 adfac3=(u(i,j,k,nrhs)+ &
1446# ifdef WEC_MELLOR
1447 & u_stokes(i,j,k)+ &
1448# endif
1449 & dc(i,k)*(cff3*cf(i,k )+ &
1450 & cff4*cf(i,k-1)))*ad_fc(i,k)
1451 adfac4=adfac3*cff1
1452 adfac5=adfac3*cff2
1453 ad_dc(i,k)=ad_dc(i,k)+(cff3*cf(i,k )+ &
1454 & cff4*cf(i,k-1))*adfac1
1455 ad_cf(i,k-1)=ad_cf(i,k-1)+cff4*adfac2
1456 ad_cf(i,k )=ad_cf(i,k )+cff3*adfac2
1457 ad_u(i,j,k,nrhs)=ad_u(i,j,k,nrhs)+adfac1
1458# ifdef WEC_MELLOR
1459 ad_u_stokes(i,j,k)=ad_u_stokes(i,j,k)+adfac1
1460# endif
1461 ad_w(i-2,j,k)=ad_w(i-2,j,k)-adfac5
1462 ad_w(i-1,j,k)=ad_w(i-1,j,k)+adfac4
1463 ad_w(i ,j,k)=ad_w(i ,j,k)+adfac4
1464 ad_w(i+1,j,k)=ad_w(i+1,j,k)-adfac5
1465 ad_fc(i,k)=0.0_r8
1466 END DO
1467 END DO
1468!
1469! Construct adjoint conservative parabolic splines for the vertical
1470! derivatives "tl_CF" of u-momentum.
1471!
1472 DO k=1,n(ng)-1 ! adjoint back substitution
1473 DO i=istru,iend
1474!^ tl_CF(i,k)=tl_CF(i,k)-FC(i,k)*tl_CF(i,k+1)
1475!^
1476 ad_cf(i,k+1)=ad_cf(i,k+1)-fc(i,k)*ad_cf(i,k)
1477 END DO
1478 END DO
1479 DO i=istru,iend
1480!^ tl_CF(i,N)=0.0_r8
1481!^
1482 ad_cf(i,n)=0.0_r8
1483 END DO ! adjoint LU decomposition
1484 DO k=n(ng)-1,1,-1 ! and forward substitution
1485 DO i=istru,iend
1486 cff=1.0_r8/(2.0_r8*dc(i,k+1)+dc(i,k)*(2.0_r8-fc(i,k-1)))
1487!^ tl_CF(i,k)=cff*(6.0_r8*(tl_u(i,j,k+1,nrhs)- &
1488# ifdef WEC_MELLOR
1489!^ & tl_u_stokes(i,j,k )+ &
1490!^ & tl_u_stokes(i,j,k+1)- &
1491# endif
1492!^ & tl_u(i,j,k ,nrhs))- &
1493!^ & (tl_DC(i,k)*CF(i,k-1)+ &
1494!^ & 2.0_r8*(tl_DC(i,k)+tl_DC(i,k+1))*CF(i,k)+ &
1495!^ & tl_DC(i,k+1)*CF(i,k+1))- &
1496!^ & DC(i,k)*tl_CF(i,k-1))
1497!^
1498 adfac=cff*ad_cf(i,k)
1499 adfac1=adfac*6.0_r8
1500 ad_cf(i,k-1)=ad_cf(i,k-1)-dc(i,k)*adfac
1501 ad_dc(i,k )=ad_dc(i,k )- &
1502 & (cf(i,k-1)+2.0_r8*cf(i,k))*adfac
1503 ad_dc(i,k+1)=ad_dc(i,k+1)- &
1504 & (cf(i,k+1)+2.0_r8*cf(i,k))*adfac
1505 ad_u(i,j,k ,nrhs)=ad_u(i,j,k ,nrhs)-adfac1
1506 ad_u(i,j,k+1,nrhs)=ad_u(i,j,k+1,nrhs)+adfac1
1507# ifdef WEC_MELLOR
1508 ad_u_stokes(i,j,k )=ad_u_stokes(i,j,k )-adfac1
1509 ad_u_stokes(i,j,k+1)=ad_u_stokes(i,j,k+1)+adfac1
1510# endif
1511 ad_cf(i,k)=0.0_r8
1512 END DO
1513 END DO
1514 DO i=istru,iend
1515!^ tl_CF(i,0)=0.0_r8
1516!^
1517 ad_cf(i,0)=0.0_r8
1518 END DO
1519 cff1=9.0_r8/16.0_r8
1520 cff2=1.0_r8/16.0_r8
1521 DO k=1,n(ng) ! adjoint triadiagonal coefficients
1522 DO i=istru,iend
1523!^ tl_DC(i,k)=cff1*(tl_Hz(i ,j,k)+ &
1524!^ & tl_Hz(i-1,j,k))- &
1525!^ & cff2*(tl_Hz(i+1,j,k)+ &
1526!^ & tl_Hz(i-2,j,k))
1527!^
1528 adfac1=cff1*ad_dc(i,k)
1529 adfac2=cff2*ad_dc(i,k)
1530 ad_hz(i-2,j,k)=ad_hz(i-2,j,k)-adfac2
1531 ad_hz(i+1,j,k)=ad_hz(i+1,j,k)-adfac2
1532 ad_hz(i-1,j,k)=ad_hz(i-1,j,k)+adfac1
1533 ad_hz(i ,j,k)=ad_hz(i ,j,k)+adfac1
1534 ad_dc(i,k)=0.0_r8
1535 END DO
1536 END DO
1537# elif defined UV_C2ADVECTION
1538!
1539! Second-order, central differences u-momentum vertical advection.
1540!
1541 DO i=istru,iend
1542!^ tl_FC(i,0)=0.0_r8
1543!^
1544 ad_fc(i,0)=0.0_r8
1545!^ tl_FC(i,N(ng))=0.0_r8
1546!^
1547 ad_fc(i,n(ng))=0.0_r8
1548 END DO
1549 DO k=1,n(ng)-1
1550 DO i=istru,iend
1551!^ tl_FC(i,k)=0.25_r8*((tl_u(i,j,k ,nrhs)+ &
1552# ifdef WEC_MELLOR
1553!^ & tl_u_stokes(i,j,k )+ &
1554!^ & tl_u_stokes(i,j,k+1)+ &
1555# endif
1556!^ & tl_u(i,j,k+1,nrhs))* &
1557!^ & (W(i ,j,k)+ &
1558!^ & W(i-1,j,k))+ &
1559!^ & (u(i,j,k ,nrhs)+ &
1560# ifdef WEC_MELLOR
1561!^ & u_stokes(i,j,k )+ &
1562!^ & u_stokes(i,j,k+1)+ &
1563# endif
1564!^ & u(i,j,k+1,nrhs))* &
1565!^ & (tl_W(i ,j,k)+ &
1566!^ & tl_W(i-1,j,k)))
1567!^
1568 adfac=0.25_r8*ad_fc(i,k)
1569 adfac1=adfac*(u(i,j,k ,nrhs)+ &
1570# ifdef WEC_MELLOR
1571 & u_stokes(i,j,k )+ &
1572 & u_stokes(i,j,k+1)+ &
1573# endif
1574 & u(i,j,k+1,nrhs))
1575 adfac2=adfac*(w(i ,j,k)+ &
1576 & w(i-1,j,k))
1577 ad_w(i-1,j,k)=ad_w(i-1,j,k)+adfac1
1578 ad_w(i ,j,k)=ad_w(i ,j,k)+adfac1
1579 ad_u(i,j,k ,nrhs)=ad_u(i,j,k ,nrhs)+adfac2
1580 ad_u(i,j,k+1,nrhs)=ad_u(i,j,k+1,nrhs)+adfac2
1581# ifdef WEC_MELLOR
1582 ad_u_stokes(i,j,k )=ad_u_stokes(i,j,k )+adfac2
1583 ad_u_stokes(i,j,k+1)=ad_u_stokes(i,j,k+1)+adfac2
1584# endif
1585 ad_fc(i,k)=0.0_r8
1586 END DO
1587 END DO
1588# elif defined UV_C4ADVECTION
1589!
1590! Fourth-order, central differences u-momentum vertical advection.
1591!
1592 cff1=9.0_r8/32.0_r8
1593 cff2=1.0_r8/32.0_r8
1594 DO i=istru,iend
1595!^ tl_FC(i,0)=0.0_r8
1596!^
1597 ad_fc(i,0)=0.0_r8
1598!^ tl_FC(i,1)=(cff1*(tl_u(i,j,1,nrhs)+ &
1599# ifdef WEC_MELLOR
1600!^ & tl_u_stokes(i,j,1)+ &
1601!^ & tl_u_stokes(i,j,2)+ &
1602# endif
1603!^ & tl_u(i,j,2,nrhs))- &
1604!^ & cff2*(tl_u(i,j,1,nrhs)+ &
1605# ifdef WEC_MELLOR
1606!^ & tl_u_stokes(i,j,1)+ &
1607!^ & tl_u_stokes(i,j,3)+ &
1608# endif
1609!^ & tl_u(i,j,3,nrhs)))* &
1610!^ & (W(i ,j,1)+ &
1611!^ & W(i-1,j,1))+ &
1612!^ & (cff1*(u(i,j,1,nrhs)+ &
1613# ifdef WEC_MELLOR
1614!^ & u_stokes(i,j,1)+ &
1615!^ & u_stokes(i,j,2)+ &
1616# endif
1617!^ & u(i,j,2,nrhs))- &
1618!^ & cff2*(u(i,j,1,nrhs)+ &
1619# ifdef WEC_MELLOR
1620!^ & u_stokes(i,j,1)+ &
1621!^ & u_stokes(i,j,3)+ &
1622# endif
1623!^ & u(i,j,3,nrhs)))* &
1624!^ & (tl_W(i ,j,1)+ &
1625!^ & tl_W(i-1,j,1))
1626!^
1627 adfac=(w(i ,j,1)+ &
1628 & w(i-1,j,1))*ad_fc(i,1)
1629 adfac1=adfac*cff1
1630 adfac2=adfac*cff2
1631 adfac3=(cff1*(u(i,j,1,nrhs)+ &
1632# ifdef WEC_MELLOR
1633 & u_stokes(i,j,1)+ &
1634 & u_stokes(i,j,2)+ &
1635# endif
1636 & u(i,j,2,nrhs))- &
1637 & cff2*(u(i,j,1,nrhs)+ &
1638# ifdef WEC_MELLOR
1639 & u_stokes(i,j,1)+ &
1640 & u_stokes(i,j,3)+ &
1641# endif
1642 & u(i,j,3,nrhs)))*ad_fc(i,1)
1643 ad_w(i-1,j,1)=ad_w(i-1,j,1)+adfac3
1644 ad_w(i ,j,1)=ad_w(i ,j,1)+adfac3
1645 ad_u(i,j,1,nrhs)=ad_u(i,j,1,nrhs)+adfac1-adfac2
1646 ad_u(i,j,2,nrhs)=ad_u(i,j,2,nrhs)+adfac1
1647 ad_u(i,j,3,nrhs)=ad_u(i,j,3,nrhs)-adfac2
1648# ifdef WEC_MELLOR
1649 ad_u_stokes(i,j,1)=ad_u_stokes(i,j,1)+adfac1-adfac2
1650 ad_u_stokes(i,j,2)=ad_u_stokes(i,j,2)+adfac1
1651 ad_u_stokes(i,j,3)=ad_u_stokes(i,j,3)-adfac2
1652# endif
1653 ad_fc(i,1)=0.0_r8
1654!^ tl_FC(i,N(ng)-1)=(cff1*(tl_u(i,j,N(ng)-1,nrhs)+ &
1655# ifdef WEC_MELLOR
1656!^ & tl_u_stokes(i,j,N(ng)-1)+ &
1657!^ & tl_u_stokes(i,j,N(ng) )+ &
1658# endif
1659!^ & tl_u(i,j,N(ng) ,nrhs))- &
1660!^ & cff2*(tl_u(i,j,N(ng)-2,nrhs)+ &
1661# ifdef WEC_MELLOR
1662!^ & tl_u_stokes(i,j,N(ng)-2)+ &
1663!^ & tl_u_stokes(i,j,N(ng) )+ &
1664# endif
1665!^ & tl_u(i,j,N(ng) ,nrhs)))* &
1666!^ & (W(i ,j,N(ng)-1)+ &
1667!^ & W(i-1,j,N(ng)-1))+ &
1668!^ & (cff1*(u(i,j,N(ng)-1,nrhs)+ &
1669# ifdef WEC_MELLOR
1670!^ & u_stokes(i,j,N(ng)-1)+ &
1671!^ & u_stokes(i,j,N(ng) )+ &
1672# endif
1673!^ & u(i,j,N(ng) ,nrhs))- &
1674!^ & cff2*(u(i,j,N(ng)-2,nrhs)+ &
1675# ifdef WEC_MELLOR
1676!^ & u_stokes(i,j,N(ng)-2)+ &
1677!^ & u_stokes(i,j,N(ng) )+ &
1678# endif
1679!^ & u(i,j,N(ng) ,nrhs)))* &
1680!^ & (tl_W(i ,j,N(ng)-1)+ &
1681!^ & tl_W(i-1,j,N(ng)-1))
1682!^
1683 adfac=(w(i ,j,n(ng)-1)+ &
1684 & w(i-1,j,n(ng)-1))*ad_fc(i,n(ng)-1)
1685 adfac1=adfac*cff1
1686 adfac2=adfac*cff2
1687 adfac3=(cff1*(u(i,j,n(ng)-1,nrhs)+ &
1688# ifdef WEC_MELLOR
1689 & u_stokes(i,j,n(ng)-1)+ &
1690 & u_stokes(i,j,n(ng) )+ &
1691# endif
1692 & u(i,j,n(ng) ,nrhs))- &
1693 & cff2*(u(i,j,n(ng)-2,nrhs)+ &
1694# ifdef WEC_MELLOR
1695 & u_stokes(i,j,n(ng)-2)+ &
1696 & u_stokes(i,j,n(ng) )+ &
1697# endif
1698 & u(i,j,n(ng) ,nrhs)))*ad_fc(i,n(ng)-1)
1699 ad_w(i ,j,n(ng)-1)=ad_w(i ,j,n(ng)-1)+adfac3
1700 ad_w(i-1,j,n(ng)-1)=ad_w(i-1,j,n(ng)-1)+adfac3
1701 ad_u(i,j,n(ng)-2,nrhs)=ad_u(i,j,n(ng)-2,nrhs)-adfac2
1702 ad_u(i,j,n(ng)-1,nrhs)=ad_u(i,j,n(ng)-1,nrhs)+adfac1
1703 ad_u(i,j,n(ng) ,nrhs)=ad_u(i,j,n(ng) ,nrhs)+adfac1-adfac2
1704# ifdef WEC_MELLOR
1705 ad_u_stokes(i,j,n(ng)-2)=ad_u_stokes(i,j,n(ng)-2)-adfac2
1706 ad_u_stokes(i,j,n(ng)-1)=ad_u_stokes(i,j,n(ng)-1)+adfac1
1707 ad_u_stokes(i,j,n(ng) )=ad_u_stokes(i,j,n(ng) )+adfac1- &
1708 & adfac2
1709# endif
1710 ad_fc(i,n(ng)-1)=0.0_r8
1711!^ tl_FC(i,N(ng))=0.0_r8
1712!^
1713 ad_fc(i,n(ng))=0.0_r8
1714 END DO
1715 DO k=2,n(ng)-2
1716 DO i=istru,iend
1717!^ tl_FC(i,k)=(cff1*(tl_u(i,j,k ,nrhs)+ &
1718# ifdef WEC_MELLOR
1719!^ & tl_u_stokes(i,j,k )+ &
1720!^ & tl_u_stokes(i,j,k+1)+ &
1721# endif
1722!^ & tl_u(i,j,k+1,nrhs))- &
1723!^ & cff2*(tl_u(i,j,k-1,nrhs)+ &
1724# ifdef WEC_MELLOR
1725!^ & tl_u_stokes(i,j,k-1)+ &
1726!^ & tl_u_stokes(i,j,k+2)+ &
1727# endif
1728!^ & tl_u(i,j,k+2,nrhs)))* &
1729!^ & (W(i ,j,k)+ &
1730!^ & W(i-1,j,k))+ &
1731!^ & (cff1*(u(i,j,k ,nrhs)+ &
1732# ifdef WEC_MELLOR
1733!^ & u_stokes(i,j,k )+ &
1734!^ & u_stokes(i,j,k+1)+ &
1735# endif
1736!^ & u(i,j,k+1,nrhs))- &
1737!^ & cff2*(u(i,j,k-1,nrhs)+ &
1738# ifdef WEC_MELLOR
1739!^ & u_stokes(i,j,k-1)+ &
1740!^ & u_stokes(i,j,k+2)+ &
1741# endif
1742!^ & u(i,j,k+2,nrhs)))* &
1743!^ & (tl_W(i ,j,k)+ &
1744!^ & tl_W(i-1,j,k))
1745!^
1746 adfac=(w(i ,j,k)+ &
1747 & w(i-1,j,k))*ad_fc(i,k)
1748 adfac1=adfac*cff1
1749 adfac2=adfac*cff2
1750 adfac3=(cff1*(u(i,j,k ,nrhs)+ &
1751# ifdef WEC_MELLOR
1752 & u_stokes(i,j,k )+ &
1753 & u_stokes(i,j,k+1)+ &
1754# endif
1755 & u(i,j,k+1,nrhs))- &
1756 & cff2*(u(i,j,k-1,nrhs)+ &
1757# ifdef WEC_MELLOR
1758 & u_stokes(i,j,k-1)+ &
1759 & u_stokes(i,j,k+2)+ &
1760# endif
1761 & u(i,j,k+2,nrhs)))*ad_fc(i,k)
1762 ad_w(i-1,j,k)=ad_w(i-1,j,k)+adfac3
1763 ad_w(i ,j,k)=ad_w(i ,j,k)+adfac3
1764 ad_u(i,j,k-1,nrhs)=ad_u(i,j,k-1,nrhs)-adfac2
1765 ad_u(i,j,k ,nrhs)=ad_u(i,j,k ,nrhs)+adfac1
1766 ad_u(i,j,k+1,nrhs)=ad_u(i,j,k+1,nrhs)+adfac1
1767 ad_u(i,j,k+2,nrhs)=ad_u(i,j,k+2,nrhs)-adfac2
1768# ifdef WEC_MELLOR
1769 ad_u_stokes(i,j,k-1)=ad_u_stokes(i,j,k-1)-adfac2
1770 ad_u_stokes(i,j,k )=ad_u_stokes(i,j,k )+adfac1
1771 ad_u_stokes(i,j,k+1)=ad_u_stokes(i,j,k+1)+adfac1
1772 ad_u_stokes(i,j,k+2)=ad_u_stokes(i,j,k+2)-adfac2
1773# endif
1774 ad_fc(i,k)=0.0_r8
1775 END DO
1776 END DO
1777# else
1778!
1779! Fourth-order, central differences u-momentum vertical advection.
1780!
1781 cff1=9.0_r8/16.0_r8
1782 cff2=1.0_r8/16.0_r8
1783 DO i=istru,iend
1784!^ tl_FC(i,0)=0.0_r8
1785!^
1786 ad_fc(i,0)=0.0_r8
1787!^ tl_FC(i,1)=(cff1*(tl_u(i,j,1,nrhs)+ &
1788# ifdef WEC_MELLOR
1789!^ & tl_u_stokes(i,j,1)+ &
1790!^ & tl_u_stokes(i,j,2)+ &
1791# endif
1792!^ & tl_u(i,j,2,nrhs))- &
1793!^ & cff2*(tl_u(i,j,1,nrhs)+ &
1794# ifdef WEC_MELLOR
1795!^ & tl_u_stokes(i,j,1)+ &
1796!^ & tl_u_stokes(i,j,3)+ &
1797# endif
1798!^ & tl_u(i,j,3,nrhs)))* &
1799!^ & (cff1*(W(i ,j,1)+ &
1800!^ & W(i-1,j,1))- &
1801!^ & cff2*(W(i+1,j,1)+ &
1802!^ & W(i-2,j,1)))+ &
1803!^ & (cff1*(u(i,j,1,nrhs)+ &
1804# ifdef WEC_MELLOR
1805!^ & u_stokes(i,j,1)+ &
1806!^ & u_stokes(i,j,2)+ &
1807# endif
1808!^ & u(i,j,2,nrhs))- &
1809!^ & cff2*(u(i,j,1,nrhs)+ &
1810# ifdef WEC_MELLOR
1811!^ & u_stokes(i,j,1)+ &
1812!^ & u_stokes(i,j,3)+ &
1813# endif
1814!^ & u(i,j,3,nrhs)))* &
1815!^ & (cff1*(tl_W(i ,j,1)+ &
1816!^ & tl_W(i-1,j,1))- &
1817!^ & cff2*(tl_W(i+1,j,1)+ &
1818!^ & tl_W(i-2,j,1)))
1819!^
1820 adfac=(cff1*(w(i ,j,1)+ &
1821 & w(i-1,j,1))- &
1822 & cff2*(w(i+1,j,1)+ &
1823 & w(i-2,j,1)))*ad_fc(i,1)
1824 adfac1=adfac*cff1
1825 adfac2=adfac*cff2
1826 adfac=(cff1*(u(i,j,1,nrhs)+ &
1827# ifdef WEC_MELLOR
1828 & u_stokes(i,j,1)+ &
1829 & u_stokes(i,j,2)+ &
1830# endif
1831 & u(i,j,2,nrhs))- &
1832 & cff2*(u(i,j,1,nrhs)+ &
1833# ifdef WEC_MELLOR
1834 & u_stokes(i,j,1)+ &
1835 & u_stokes(i,j,3)+ &
1836# endif
1837 & u(i,j,3,nrhs)))*ad_fc(i,1)
1838 adfac3=adfac*cff1
1839 adfac4=adfac*cff2
1840 ad_w(i-2,j,1)=ad_w(i-2,j,1)-adfac4
1841 ad_w(i-1,j,1)=ad_w(i-1,j,1)+adfac3
1842 ad_w(i ,j,1)=ad_w(i ,j,1)+adfac3
1843 ad_w(i+1,j,1)=ad_w(i+1,j,1)-adfac4
1844 ad_u(i,j,1,nrhs)=ad_u(i,j,1,nrhs)+adfac1-adfac2
1845 ad_u(i,j,2,nrhs)=ad_u(i,j,2,nrhs)+adfac1
1846 ad_u(i,j,3,nrhs)=ad_u(i,j,3,nrhs)-adfac2
1847# ifdef WEC_MELLOR
1848 ad_u_stokes(i,j,1)=ad_u_stokes(i,j,1)+adfac1-adfac2
1849 ad_u_stokes(i,j,2)=ad_u_stokes(i,j,2)+adfac1
1850 ad_u_stokes(i,j,3)=ad_u_stokes(i,j,3)-adfac2
1851# endif
1852 ad_fc(i,1)=0.0_r8
1853!^ tl_FC(i,N(ng)-1)=(cff1*(tl_u(i,j,N(ng)-1,nrhs)+ &
1854# ifdef WEC_MELLOR
1855!^ & tl_u_stokes(i,j,N(ng)-1)+ &
1856!^ & tl_u_stokes(i,j,N(ng) )+ &
1857# endif
1858!^ & tl_u(i,j,N(ng) ,nrhs))- &
1859!^ & cff2*(tl_u(i,j,N(ng)-2,nrhs)+ &
1860# ifdef WEC_MELLOR
1861!^ & tl_u_stokes(i,j,N(ng)-2)+ &
1862!^ & tl_u_stokes(i,j,N(ng) )+ &
1863# endif
1864!^ & tl_u(i,j,N(ng) ,nrhs)))* &
1865!^ & (cff1*(W(i ,j,N(ng)-1)+ &
1866!^ & W(i-1,j,N(ng)-1))- &
1867!^ & cff2*(W(i+1,j,N(ng)-1)+ &
1868!^ & W(i-2,j,N(ng)-1)))+ &
1869!^ & (cff1*(u(i,j,N(ng)-1,nrhs)+ &
1870# ifdef WEC_MELLOR
1871!^ & u_stokes(i,j,N(ng)-1)+ &
1872!^ & u_stokes(i,j,N(ng) )+ &
1873# endif
1874!^ & u(i,j,N(ng) ,nrhs))- &
1875!^ & cff2*(u(i,j,N(ng)-2,nrhs)+ &
1876# ifdef WEC_MELLOR
1877!^ & u_stokes(i,j,N(ng)-2)+ &
1878!^ & u_stokes(i,j,N(ng) )+ &
1879# endif
1880!^ & u(i,j,N(ng) ,nrhs)))* &
1881!^ & (cff1*(tl_W(i ,j,N(ng)-1)+ &
1882!^ & tl_W(i-1,j,N(ng)-1))- &
1883!^ & cff2*(tl_W(i+1,j,N(ng)-1)+ &
1884!^ & tl_W(i-2,j,N(ng)-1)))
1885!^
1886 adfac=(cff1*(w(i ,j,n(ng)-1)+ &
1887 & w(i-1,j,n(ng)-1))- &
1888 & cff2*(w(i+1,j,n(ng)-1)+ &
1889 & w(i-2,j,n(ng)-1)))*ad_fc(i,n(ng)-1)
1890 adfac1=adfac*cff1
1891 adfac2=adfac*cff2
1892 adfac=(cff1*(u(i,j,n(ng)-1,nrhs)+ &
1893# ifdef WEC_MELLOR
1894 & u_stokes(i,j,n(ng)-1)+ &
1895 & u_stokes(i,j,n(ng) )+ &
1896# endif
1897 & u(i,j,n(ng) ,nrhs))- &
1898 & cff2*(u(i,j,n(ng)-2,nrhs)+ &
1899# ifdef WEC_MELLOR
1900 & u_stokes(i,j,n(ng)-2)+ &
1901 & u_stokes(i,j,n(ng) )+ &
1902# endif
1903 & u(i,j,n(ng) ,nrhs)))*ad_fc(i,n(ng)-1)
1904 adfac3=adfac*cff1
1905 adfac4=adfac*cff2
1906 ad_w(i-2,j,n(ng)-1)=ad_w(i-2,j,n(ng)-1)-adfac4
1907 ad_w(i-1,j,n(ng)-1)=ad_w(i-1,j,n(ng)-1)+adfac3
1908 ad_w(i ,j,n(ng)-1)=ad_w(i ,j,n(ng)-1)+adfac3
1909 ad_w(i+1,j,n(ng)-1)=ad_w(i+1,j,n(ng)-1)-adfac4
1910 ad_u(i,j,n(ng)-2,nrhs)=ad_u(i,j,n(ng)-2,nrhs)-adfac2
1911 ad_u(i,j,n(ng)-1,nrhs)=ad_u(i,j,n(ng)-1,nrhs)+adfac1
1912 ad_u(i,j,n(ng) ,nrhs)=ad_u(i,j,n(ng) ,nrhs)+adfac1-adfac2
1913# ifdef WEC_MELLOR
1914 ad_u_stokes(i,j,n(ng)-2)=ad_u_stokes(i,j,n(ng)-2)-adfac2
1915 ad_u_stokes(i,j,n(ng)-1)=ad_u_stokes(i,j,n(ng)-1)+adfac1
1916 ad_u_stokes(i,j,n(ng) )=ad_u_stokes(i,j,n(ng) )+adfac1- &
1917 & adfac2
1918# endif
1919 ad_fc(i,n(ng)-1)=0.0_r8
1920!^ tl_FC(i,N)=0.0_r8
1921!^
1922 ad_fc(i,n(ng))=0.0_r8
1923 END DO
1924 DO k=2,n(ng)-2
1925 DO i=istru,iend
1926!^ tl_FC(i,k)=(cff1*(tl_u(i,j,k ,nrhs)+ &
1927# ifdef WEC_MELLOR
1928!^ & tl_u_stokes(i,j,k )+ &
1929!^ & tl_u_stokes(i,j,k+1)+ &
1930# endif
1931!^ & tl_u(i,j,k+1,nrhs))- &
1932!^ & cff2*(tl_u(i,j,k-1,nrhs)+ &
1933# ifdef WEC_MELLOR
1934!^ & tl_u_stokes(i,j,k-1)+ &
1935!^ & tl_u_stokes(i,j,k+2)+ &
1936# endif
1937!^ & tl_u(i,j,k+2,nrhs)))* &
1938!^ & (cff1*(W(i ,j,k)+ &
1939!^ & W(i-1,j,k))- &
1940!^ & cff2*(W(i+1,j,k)+ &
1941!^ & W(i-2,j,k)))+ &
1942!^ & (cff1*(u(i,j,k ,nrhs)+ &
1943# ifdef WEC_MELLOR
1944!^ & u_stokes(i,j,k )+ &
1945!^ & u_stokes(i,j,k+1)+ &
1946# endif
1947!^ & u(i,j,k+1,nrhs))- &
1948!^ & cff2*(u(i,j,k-1,nrhs)+ &
1949# ifdef WEC_MELLOR
1950!^ & u_stokes(i,j,k-1)+ &
1951!^ & u_stokes(i,j,k+2)+ &
1952# endif
1953!^ & u(i,j,k+2,nrhs)))* &
1954!^ & (cff1*(tl_W(i ,j,k)+ &
1955!^ & tl_W(i-1,j,k))- &
1956!^ & cff2*(tl_W(i+1,j,k)+ &
1957!^ & tl_W(i-2,j,k)))
1958!^
1959 adfac=(cff1*(w(i ,j,k)+ &
1960 & w(i-1,j,k))- &
1961 & cff2*(w(i+1,j,k)+ &
1962 & w(i-2,j,k)))*ad_fc(i,k)
1963 adfac1=adfac*cff1
1964 adfac2=adfac*cff2
1965 adfac=(cff1*(u(i,j,k ,nrhs)+ &
1966# ifdef WEC_MELLOR
1967 & u_stokes(i,j,k )+ &
1968 & u_stokes(i,j,k+1)+ &
1969# endif
1970 & u(i,j,k+1,nrhs))- &
1971 & cff2*(u(i,j,k-1,nrhs)+ &
1972# ifdef WEC_MELLOR
1973 & u_stokes(i,j,k-1)+ &
1974 & u_stokes(i,j,k+2)+ &
1975# endif
1976 & u(i,j,k+2,nrhs)))*ad_fc(i,k)
1977 adfac3=adfac*cff1
1978 adfac4=adfac*cff2
1979 ad_w(i-2,j,k)=ad_w(i-2,j,k)-adfac4
1980 ad_w(i-1,j,k)=ad_w(i-1,j,k)+adfac3
1981 ad_w(i ,j,k)=ad_w(i ,j,k)+adfac3
1982 ad_w(i+1,j,k)=ad_w(i+1,j,k)-adfac4
1983 ad_u(i,j,k-1,nrhs)=ad_u(i,j,k-1,nrhs)-adfac2
1984 ad_u(i,j,k ,nrhs)=ad_u(i,j,k ,nrhs)+adfac1
1985 ad_u(i,j,k+1,nrhs)=ad_u(i,j,k+1,nrhs)+adfac1
1986 ad_u(i,j,k+2,nrhs)=ad_u(i,j,k+2,nrhs)-adfac2
1987# ifdef WEC_MELLOR
1988 ad_u_stokes(i,j,k-1)=ad_u_stokes(i,j,k-1)-adfac2
1989 ad_u_stokes(i,j,k )=ad_u_stokes(i,j,k )+adfac1
1990 ad_u_stokes(i,j,k+1)=ad_u_stokes(i,j,k+1)+adfac1
1991 ad_u_stokes(i,j,k+2)=ad_u_stokes(i,j,k+2)-adfac2
1992# endif
1993 ad_fc(i,k)=0.0_r8
1994 END DO
1995 END DO
1996# endif
1997# endif
1998 END DO j_loop
1999
2000 k_loop : DO k=1,n(ng)
2001
2002# ifdef WEC_MELLOR
2003!
2004!-----------------------------------------------------------------------
2005! Add in adjoint radiation stress terms.
2006!-----------------------------------------------------------------------
2007!
2008 DO j=jstrv,jend
2009 DO i=istr,iend
2010!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)- &
2011!^ & tl_rvstr3d(i,j,k)*om_v(i,j)*on_v(i,j)- &
2012!^ & tl_rvlag3d(i,j,k)
2013!^
2014 ad_rvstr3d(i,j,k)=ad_rvstr3d(i,j,k)- &
2015 & om_v(i,j)*on_v(i,j)*ad_rv(i,j,k,nrhs)
2016 ad_rvlag3d(i,j,k)=ad_rvlag3d(i,j,k)-ad_rv(i,j,k,nrhs)
2017 END DO
2018 END DO
2019 DO j=jstr,jend
2020 DO i=istru,iend
2021!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)- &
2022!^ & tl_rustr3d(i,j,k)*om_u(i,j)*on_u(i,j)- &
2023!^ & tl_rulag3d(i,j,k)
2024!^
2025 ad_rustr3d(i,j,k)=ad_rustr3d(i,j,k)- &
2026 & om_u(i,j)*on_u(i,j)*ad_ru(i,j,k,nrhs)
2027 ad_rulag3d(i,j,k)=ad_rulag3d(i,j,k)-ad_ru(i,j,k,nrhs)
2028 END DO
2029 END DO
2030# endif
2031
2032# ifdef UV_ADV
2033!
2034!-----------------------------------------------------------------------
2035! Add in adjoint horizontal advection of momentum.
2036!-----------------------------------------------------------------------
2037!
2038! Add in adjoint horizontal advection.
2039!
2040 DO j=jstrv,jend
2041 DO i=istr,iend
2042# ifdef DIAGNOSTICS_UV
2043# ifdef CURVGRID
2044!! DiaRV(i,j,k,nrhs,M3hadv)=DiaRV(i,j,k,nrhs,M3hadv)-cff
2045!! DiaRV(i,j,k,nrhs,M3yadv)=DiaRV(i,j,k,nrhs,M3yadv)-cff2
2046!! DiaRV(i,j,k,nrhs,M3xadv)=DiaRV(i,j,k,nrhs,M3xadv)-cff1
2047# else
2048!! DiaRV(i,j,k,nrhs,M3hadv)=-cff
2049!! DiaRV(i,j,k,nrhs,M3yadv)=-cff2
2050!! DiaRV(i,j,k,nrhs,M3xadv)=-cff1
2051# endif
2052# endif
2053!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)-tl_cff
2054!^
2055 ad_cff=ad_cff-ad_rv(i,j,k,nrhs)
2056!^ tl_cff=tl_cff1+tl_cff2
2057!^
2058 ad_cff1=ad_cff1+ad_cff
2059 ad_cff2=ad_cff2+ad_cff
2060 ad_cff=0.0_r8
2061!^ tl_cff2=tl_VFe(i,j)-tl_VFe(i,j-1)
2062!^
2063 ad_vfe(i,j-1)=ad_vfe(i,j-1)-ad_cff2
2064 ad_vfe(i,j )=ad_vfe(i,j )+ad_cff2
2065 ad_cff2=0.0_r8
2066!^ tl_cff1=tl_VFx(i+1,j)-tl_VFx(i,j)
2067!^
2068 ad_vfx(i ,j)=ad_vfx(i ,j)-ad_cff1
2069 ad_vfx(i+1,j)=ad_vfx(i+1,j)+ad_cff1
2070 ad_cff1=0.0_r8
2071 END DO
2072 END DO
2073 DO j=jstr,jend
2074 DO i=istru,iend
2075# ifdef DIAGNOSTICS_UV
2076# ifdef CURVGRID
2077!! DiaRU(i,j,k,nrhs,M3hadv)=DiaRU(i,j,k,nrhs,M3hadv)-cff
2078!! DiaRU(i,j,k,nrhs,M3yadv)=DiaRU(i,j,k,nrhs,M3yadv)-cff2
2079!! DiaRU(i,j,k,nrhs,M3xadv)=DiaRU(i,j,k,nrhs,M3xadv)-cff1
2080# else
2081!! DiaRU(i,j,k,nrhs,M3hadv)=-cff
2082!! DiaRU(i,j,k,nrhs,M3yadv)=-cff2
2083!! DiaRU(i,j,k,nrhs,M3xadv)=-cff1
2084# endif
2085# endif
2086!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)-tl_cff
2087!^
2088 ad_cff=ad_cff-ad_ru(i,j,k,nrhs)
2089!^ tl_cff=tl_cff1+tl_cff2
2090!^
2091 ad_cff1=ad_cff1+ad_cff
2092 ad_cff2=ad_cff2+ad_cff
2093 ad_cff=0.0_r8
2094!^ tl_cff2=tl_UFe(i,j+1)-tl_UFe(i,j)
2095!^
2096 ad_ufe(i,j )=ad_ufe(i,j )-ad_cff2
2097 ad_ufe(i,j+1)=ad_ufe(i,j+1)+ad_cff2
2098 ad_cff2=0.0_r8
2099!^ tl_cff1=tl_UFx(i,j)-tl_UFx(i-1,j)
2100!^
2101 ad_ufx(i-1,j)=ad_ufx(i-1,j)-ad_cff1
2102 ad_ufx(i ,j)=ad_ufx(i ,j)+ad_cff1
2103 ad_cff1=0.0_r8
2104 END DO
2105 END DO
2106# ifdef UV_C2ADVECTION
2107!
2108! Second-order, centered differences advection.
2109!
2110 DO j=jstrv-1,jend
2111 DO i=istr,iend
2112!^ tl_VFe(i,j)=0.25_r8* &
2113!^ & ((tl_v(i,j ,k,nrhs)+ &
2114# ifdef WEC_MELLOR
2115!^ & tl_v_stokes(i,j ,k)+ &
2116!^ & tl_v_stokes(i,j+1,k)+ &
2117# endif
2118!^ & tl_v(i,j+1,k,nrhs))* &
2119!^ & (Hvom(i,j ,k)+ &
2120!^ & Hvom(i,j+1,k))+ &
2121!^ & (v(i,j ,k,nrhs)+ &
2122# ifdef WEC_MELLOR
2123!^ & v_stokes(i,j ,k)+ &
2124!^ & v_stokes(i,j+1,k)+ &
2125# endif
2126!^ & v(i,j+1,k,nrhs))* &
2127!^ & (tl_Hvom(i,j ,k)+ &
2128!^ & tl_Hvom(i,j+1,k)))
2129!^
2130 adfac=0.25_r8*ad_vfe(i,j)
2131 adfac1=adfac*(v(i,j ,k,nrhs)+ &
2132# ifdef WEC_MELLOR
2133 & v_stokes(i,j ,k)+ &
2134 & v_stokes(i,j+1,k)+ &
2135# endif
2136 & v(i,j+1,k,nrhs))
2137 adfac2=adfac*(hvom(i,j ,k)+ &
2138 & hvom(i,j+1,k))
2139 ad_hvom(i,j ,k)=ad_hvom(i,j ,k)+adfac1
2140 ad_hvom(i,j+1,k)=ad_hvom(i,j+1,k)+adfac1
2141 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)+adfac2
2142 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+adfac2
2143# ifdef WEC_MELLOR
2144 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)+adfac2
2145 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+adfac2
2146# endif
2147 ad_vfe(i,j)=0.0_r8
2148 END DO
2149 END DO
2150 DO j=jstrv,jend
2151 DO i=istr,iend+1
2152!^ tl_VFx(i,j)=0.25_r8* &
2153!^ & ((tl_v(i-1,j,k,nrhs)+ &
2154# ifdef WEC_MELLOR
2155!^ & tl_v_stokes(i-1,j,k)+ &
2156!^ & tl_v_stokes(i ,j,k)+ &
2157# endif
2158!^ & tl_v(i ,j,k,nrhs))* &
2159!^ & (Huon(i,j-1,k)+ &
2160!^ & Huon(i,j ,k))+ &
2161!^ & (v(i-1,j,k,nrhs)+ &
2162# ifdef WEC_MELLOR
2163!^ & v_stokes(i-1,j,k)+ &
2164!^ & v_stokes(i ,j,k)+ &
2165# endif
2166!^ & v(i ,j,k,nrhs))* &
2167!^ & (tl_Huon(i,j-1,k)+ &
2168!^ & tl_Huon(i,j ,k)))
2169!^
2170 adfac=0.25_r8*ad_vfx(i,j)
2171 adfac1=adfac*(v(i-1,j,k,nrhs)+ &
2172# ifdef WEC_MELLOR
2173 & v_stokes(i-1,j,k)+ &
2174 & v_stokes(i ,j,k)+ &
2175# endif
2176 & v(i ,j,k,nrhs))
2177 adfac2=adfac*(huon(i,j-1,k)+ &
2178 & huon(i,j ,k))
2179 ad_huon(i,j-1,k)=ad_huon(i,j-1,k)+adfac1
2180 ad_huon(i,j ,k)=ad_huon(i,j ,k)+adfac1
2181 ad_v(i-1,j,k,nrhs)=ad_v(i-1,j,k,nrhs)+adfac2
2182 ad_v(i ,j,k,nrhs)=ad_v(i ,j,k,nrhs)+adfac2
2183# ifdef WEC_MELLOR
2184 ad_v_stokes(i-1,j,k)=ad_v_stokes(i-1,j,k)+adfac2
2185 ad_v_stokes(i ,j,k)=ad_v_stokes(i ,j,k)+adfac2
2186# endif
2187 ad_vfx(i,j)=0.0_r8
2188 END DO
2189 END DO
2190 DO j=jstr,jend+1
2191 DO i=istru,iend
2192!^ tl_UFe(i,j)=0.25_r8* &
2193!^ & ((tl_u(i,j-1,k,nrhs)+ &
2194# ifdef WEC_MELLOR
2195!^ & tl_u_stokes(i,j-1,k)+ &
2196!^ & tl_u_stokes(i,j ,k)+ &
2197# endif
2198!^ & tl_u(i,j ,k,nrhs))* &
2199!^ & (Hvom(i-1,j,k)+ &
2200!^ & Hvom(i ,j,k))+ &
2201!^ & (u(i,j-1,k,nrhs)+ &
2202# ifdef WEC_MELLOR
2203!^ & u_stokes(i,j-1,k)+ &
2204!^ & u_stokes(i,j ,k)+ &
2205# endif
2206!^ & u(i,j ,k,nrhs))* &
2207!^ & (tl_Hvom(i-1,j,k)+ &
2208!^ & tl_Hvom(i ,j,k)))
2209!^
2210 adfac=0.25_r8*ad_ufe(i,j)
2211 adfac1=adfac*(u(i,j-1,k,nrhs)+ &
2212# ifdef WEC_MELLOR
2213 & u_stokes(i,j-1,k)+ &
2214 & u_stokes(i,j ,k)+ &
2215# endif
2216 & u(i,j ,k,nrhs))
2217 adfac2=adfac*(hvom(i-1,j,k)+ &
2218 & hvom(i ,j,k))
2219 ad_hvom(i-1,j,k)=ad_hvom(i-1,j,k)+adfac1
2220 ad_hvom(i ,j,k)=ad_hvom(i ,j,k)+adfac1
2221 ad_u(i,j-1,k,nrhs)=ad_u(i,j-1,k,nrhs)+adfac2
2222 ad_u(i,j ,k,nrhs)=ad_u(i,j ,k,nrhs)+adfac2
2223# ifdef WEC_MELLOR
2224 ad_u_stokes(i,j-1,k)=ad_u_stokes(i,j-1,k)+adfac2
2225 ad_u_stokes(i,j ,k)=ad_u_stokes(i,j ,k)+adfac2
2226# endif
2227 ad_ufe(i,j)=0.0_r8
2228 END DO
2229 END DO
2230 DO j=jstr,jend
2231 DO i=istru-1,iend
2232!^ tl_UFx(i,j)=0.25_r8* &
2233!^ & ((tl_u(i ,j,k,nrhs)+ &
2234# ifdef WEC_MELLOR
2235!^ & tl_u_stokes(i ,j,k)+ &
2236!^ & tl_u_stokes(i+1,j,k)+ &
2237# endif
2238!^ & tl_u(i+1,j,k,nrhs))* &
2239!^ & (Huon(i ,j,k)+ &
2240!^ & Huon(i+1,j,k))+ &
2241!^ & (u(i ,j,k,nrhs)+ &
2242# ifdef WEC_MELLOR
2243!^ & u_stokes(i ,j,k)+ &
2244!^ & u_stokes(i+1,j,k)+ &
2245# endif
2246!^ & u(i+1,j,k,nrhs))* &
2247!^ & (tl_Huon(i ,j,k)+ &
2248!^ & tl_Huon(i+1,j,k)))
2249!^
2250 adfac=0.25_r8*ad_ufx(i,j)
2251 adfac1=adfac*(u(i ,j,k,nrhs)+ &
2252# ifdef WEC_MELLOR
2253 & u_stokes(i ,j,k)+ &
2254 & u_stokes(i+1,j,k)+ &
2255# endif
2256 & u(i+1,j,k,nrhs))
2257 adfac2=adfac*(huon(i ,j,k)+ &
2258 & huon(i+1,j,k))
2259 ad_huon(i ,j,k)=ad_huon(i ,j,k)+adfac1
2260 ad_huon(i+1,j,k)=ad_huon(i+1,j,k)+adfac1
2261 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)+adfac2
2262 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+adfac2
2263# ifdef WEC_MELLOR
2264 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)+adfac2
2265 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+adfac2
2266# endif
2267 ad_ufx(i,j)=0.0_r8
2268 END DO
2269 END DO
2270# else
2271!
2272# ifdef UV_C4ADVECTION
2273! Fourth-order, centered differences v-momentum advection.
2274# else
2275! Third-order, upstream bias v-momentum advection with velocity
2276! dependent hyperdiffusion.
2277# endif
2278!
2279 DO j=jstrvm1,jendp1
2280 DO i=istr,iend
2281 vee(i,j)=v(i,j-1,k,nrhs)-2.0_r8*v(i,j,k,nrhs)+ &
2282# ifdef WEC_MELLOR
2283 & v_stokes(i,j-1,k)-2.0_r8*v_stokes(i,j,k)+ &
2284 & v_stokes(i,j+1,k)+ &
2285# endif
2286 & v(i,j+1,k,nrhs)
2287 hvee(i,j)=hvom(i,j-1,k)-2.0_r8*hvom(i,j,k)+hvom(i,j+1,k)
2288 END DO
2289 END DO
2290 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2291 IF (domain(ng)%Southern_Edge(tile)) THEN
2292 DO i=istr,iend
2293 vee(i,jstr)=vee(i,jstr+1)
2294 hvee(i,jstr)=hvee(i,jstr+1)
2295 END DO
2296 END IF
2297 END IF
2298 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2299 IF (domain(ng)%Northern_Edge(tile)) THEN
2300 DO i=istr,iend
2301 vee(i,jend+1)=vee(i,jend)
2302 hvee(i,jend+1)=hvee(i,jend)
2303 END DO
2304 END IF
2305 END IF
2306# ifdef UV_C4ADVECTION
2307 cff=1.0_r8/6.0_r8
2308 DO j=jstrv-1,jend
2309 DO i=istr,iend
2310!^ tl_VFe(i,j)=0.25_r8*((tl_v(i,j ,k,nrhs)+ &
2311# ifdef WEC_MELLOR
2312!^ & tl_v_stokes(i,j ,k)+ &
2313!^ & tl_v_stokes(i,j+1,k)+ &
2314# endif
2315!^ & tl_v(i,j+1,k,nrhs)- &
2316!^ & cff*(tl_vee (i,j )+ &
2317!^ & tl_vee (i,j+1)))* &
2318!^ & (Hvom(i,j ,k)+ &
2319!^ & Hvom(i,j+1,k)- &
2320!^ & cff*(Hvee(i,j )+ &
2321!^ & Hvee(i,j+1)))+ &
2322!^ & (v(i,j ,k,nrhs)+ &
2323# ifdef WEC_MELLOR
2324!^ & v_stokes(i,j ,k)+ &
2325!^ & v_stokes(i,j+1,k)+ &
2326# endif
2327!^ & v(i,j+1,k,nrhs)- &
2328!^ & cff*(vee (i,j )+ &
2329!^ & vee (i,j+1)))* &
2330!^ & (tl_Hvom(i,j ,k)+ &
2331!^ & tl_Hvom(i,j+1,k)- &
2332!^ & cff*(tl_Hvee(i,j )+ &
2333!^ & tl_Hvee(i,j+1))))
2334!^
2335 adfac=0.25_r8*ad_vfe(i,j)
2336 adfac1=adfac*(v(i,j ,k,nrhs)+ &
2337# ifdef WEC_MELLOR
2338 & v_stokes(i,j ,k)+ &
2339 & v_stokes(i,j+1,k)+ &
2340# endif
2341 & v(i,j+1,k,nrhs)- &
2342 & cff*(vee(i,j )+ &
2343 & vee(i,j+1)))
2344 adfac2=adfac1*cff
2345 adfac3=adfac*(hvom(i,j ,k)+ &
2346 & hvom(i,j+1,k)- &
2347 & cff*(hvee(i,j )+ &
2348 & hvee(i,j+1)))
2349 adfac4=adfac3*cff
2350 ad_hvom(i,j ,k)=ad_hvom(i,j ,k)+adfac1
2351 ad_hvom(i,j+1,k)=ad_hvom(i,j+1,k)+adfac1
2352 ad_hvee(i,j )=ad_hvee(i,j )-adfac2
2353 ad_hvee(i,j+1)=ad_hvee(i,j+1)-adfac2
2354 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)+adfac3
2355 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+adfac3
2356# ifdef WEC_MELLOR
2357 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)+adfac3
2358 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+adfac3
2359# endif
2360 ad_vee(i,j )=ad_vee(i,j )-adfac4
2361 ad_vee(i,j+1)=ad_vee(i,j+1)-adfac4
2362 ad_vfe(i,j)=0.0_r8
2363 END DO
2364 END DO
2365# else
2366 DO j=jstrv-1,jend
2367 DO i=istr,iend
2368 cff1=v(i,j ,k,nrhs)+ &
2369# ifdef WEC_MELLOR
2370 & v_stokes(i,j ,k)+ &
2371 & v_stokes(i,j+1,k)+ &
2372# endif
2373 & v(i,j+1,k,nrhs)
2374 IF (cff1.gt.0.0_r8) THEN
2375 cff=vee(i,j)
2376 ELSE
2377 cff=vee(i,j+1)
2378 END IF
2379!^ tl_VFe(i,j)=0.25_r8* &
2380!^ & ((tl_cff1+Gadv*tl_cff)* &
2381!^ & (Hvom(i,j ,k)+ &
2382!^ & Hvom(i,j+1,k)+ &
2383!^ & Gadv*0.5_r8*(Hvee(i,j )+ &
2384!^ & Hvee(i,j+1)))+ &
2385!^ & (cff1+Gadv*cff)* &
2386!^ & (tl_Hvom(i,j ,k)+ &
2387!^ & tl_Hvom(i,j+1,k)+ &
2388!^ & Gadv*0.5_r8*(tl_Hvee(i,j )+ &
2389!^ & tl_Hvee(i,j+1)))
2390!^
2391 adfac=0.25_r8*ad_vfe(i,j)
2392 adfac1=adfac*(cff1+gadv*cff)
2393 adfac2=adfac1*gadv*0.5_r8
2394 adfac3=adfac*(hvom(i,j ,k)+ &
2395 & hvom(i,j+1,k)+ &
2396 & gadv*0.5_r8*(hvee(i,j )+ &
2397 & hvee(i,j+1)))
2398 ad_hvom(i,j ,k)=ad_hvom(i,j ,k)+adfac1
2399 ad_hvom(i,j+1,k)=ad_hvom(i,j+1,k)+adfac1
2400 ad_hvee(i,j )=ad_hvee(i,j )+adfac2
2401 ad_hvee(i,j+1)=ad_hvee(i,j+1)+adfac2
2402 ad_cff=ad_cff+gadv*adfac3
2403 ad_cff1=ad_cff1+adfac3
2404 ad_vfe(i,j)=0.0_r8
2405 IF (cff1.gt.0.0_r8) THEN
2406!^ tl_cff=tl_vee(i,j)
2407!^
2408 ad_vee(i,j)=ad_vee(i,j)+ad_cff
2409 ad_cff=0.0_r8
2410 ELSE
2411!^ tl_cff=tl_vee(i,j+1)
2412!^
2413 ad_vee(i,j+1)=ad_vee(i,j+1)+ad_cff
2414 ad_cff=0.0_r8
2415 END IF
2416!^ tl_cff1=tl_v(i,j ,k,nrhs)+ &
2417# ifdef WEC_MELLOR
2418!^ & tl_v_stokes(i,j ,k)+ &
2419!^ & tl_v_stokes(i,j+1,k)+ &
2420# endif
2421!^ & tl_v(i,j+1,k,nrhs)
2422!^
2423 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)+ad_cff1
2424 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+ad_cff1
2425# ifdef WEC_MELLOR
2426 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)+ad_cff1
2427 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+ad_cff1
2428# endif
2429 ad_cff1=0.0_r8
2430 END DO
2431 END DO
2432# endif
2433 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2434 IF (domain(ng)%Northern_Edge(tile)) THEN
2435 DO i=istr,iend
2436!^ tl_Hvee(i,Jend+1)=tl_Hvee(i,Jend)
2437!^
2438 ad_hvee(i,jend)=ad_hvee(i,jend)+ad_hvee(i,jend+1)
2439 ad_hvee(i,jend+1)=0.0_r8
2440!^ tl_vee (i,Jend+1)=tl_vee (i,Jend)
2441!^
2442 ad_vee(i,jend)=ad_vee(i,jend)+ad_vee(i,jend+1)
2443 ad_vee(i,jend+1)=0.0_r8
2444 END DO
2445 END IF
2446 END IF
2447 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2448 IF (domain(ng)%Southern_Edge(tile)) THEN
2449 DO i=istr,iend
2450!^ tl_Hvee(i,Jstr)=tl_Hvee(i,Jstr+1)
2451!^
2452 ad_hvee(i,jstr+1)=ad_hvee(i,jstr+1)+ad_hvee(i,jstr)
2453 ad_hvee(i,jstr)=0.0_r8
2454!^ tl_vee (i,Jstr)=tl_vee (i,Jstr+1)
2455!^
2456 ad_vee(i,jstr+1)=ad_vee(i,jstr+1)+ad_vee(i,jstr)
2457 ad_vee(i,jstr)=0.0_r8
2458 END DO
2459 END IF
2460 END IF
2461 DO j=jstrvm1,jendp1
2462 DO i=istr,iend
2463!^ tl_Hvee(i,j)=tl_Hvom(i,j-1,k)-2.0_r8*tl_Hvom(i,j,k)+ &
2464!^ & tl_Hvom(i,j+1,k)
2465!^
2466 ad_hvom(i,j-1,k)=ad_hvom(i,j-1,k)+ad_hvee(i,j)
2467 ad_hvom(i,j ,k)=ad_hvom(i,j ,k)-2.0_r8*ad_hvee(i,j)
2468 ad_hvom(i,j+1,k)=ad_hvom(i,j+1,k)+ad_hvee(i,j)
2469 ad_hvee(i,j)=0.0_r8
2470!^ tl_vee(i,j)=tl_v(i,j-1,k,nrhs)-2.0_r8*tl_v(i,j,k,nrhs)+ &
2471# ifdef WEC_MELLOR
2472!^ tl_v_stokes(i,j-1,k)-2.0_r8*tl_v_stokes(i,j,k)+ &
2473!^ & tl_v_stokes(i,j+1,k)
2474# endif
2475!^ & tl_v(i,j+1,k,nrhs)
2476!^
2477 ad_v(i,j-1,k,nrhs)=ad_v(i,j-1,k,nrhs)+ad_vee(i,j)
2478 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)-2.0_r8*ad_vee(i,j)
2479 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+ad_vee(i,j)
2480# ifdef WEC_MELLOR
2481 ad_v_stokes(i,j-1,k)=ad_v_stokes(i,j-1,k)+ad_vee(i,j)
2482 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)-2.0_r8*ad_vee(i,j)
2483 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+ad_vee(i,j)
2484# endif
2485 ad_vee(i,j)=0.0_r8
2486 END DO
2487 END DO
2488 DO j=jstrv,jend
2489 DO i=istrm1,iendp1
2490 vxx(i,j)=v(i-1,j,k,nrhs)-2.0_r8*v(i,j,k,nrhs)+ &
2491# ifdef WEC_MELLOR
2492 & v_stokes(i-1,j,k)-2.0_r8*v_stokes(i,j,k)+ &
2493 & v_stokes(i+1,j,k)+ &
2494# endif
2495 & v(i+1,j,k,nrhs)
2496 END DO
2497 END DO
2498 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2499 IF (domain(ng)%Western_Edge(tile)) THEN
2500 DO j=jstrv,jend
2501 vxx(istr-1,j)=vxx(istr,j)
2502 END DO
2503 END IF
2504 END IF
2505 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2506 IF (domain(ng)%Eastern_Edge(tile)) THEN
2507 DO j=jstrv,jend
2508 vxx(iend+1,j)=vxx(iend,j)
2509 END DO
2510 END IF
2511 END IF
2512 DO j=jstrv-1,jend
2513 DO i=istr,iend+1
2514 huee(i,j)=huon(i,j-1,k)-2.0_r8*huon(i,j,k)+huon(i,j+1,k)
2515 END DO
2516 END DO
2517# ifdef UV_C4ADVECTION
2518 cff=1.0_r8/6.0_r8
2519 DO j=jstrv,jend
2520 DO i=istr,iend+1
2521!^ tl_VFx(i,j)=0.25_r8*((tl_v(i ,j,k,nrhs)+ &
2522# ifdef WEC_MELLOR
2523!^ & tl_v_stokes(i ,j,k)+ &
2524!^ & tl_v_stokes(i-1,j,k)+ &
2525# endif
2526!^ & tl_v(i-1,j,k,nrhs)- &
2527!^ & cff*(tl_vxx (i ,j)+ &
2528!^ & tl_vxx (i-1,j)))* &
2529!^ & (Huon(i,j ,k)+ &
2530!^ & Huon(i,j-1,k)- &
2531!^ & cff*(Huee(i,j )+ &
2532!^ & Huee(i,j-1)))+ &
2533!^ & (v(i ,j,k,nrhs)+ &
2534# ifdef WEC_MELLOR
2535!^ & v_stokes(i ,j,k)+ &
2536!^ & v_stokes(i-1,j,k)+ &
2537# endif
2538!^ & v(i-1,j,k,nrhs)- &
2539!^ & cff*(vxx (i ,j)+ &
2540!^ & vxx (i-1,j)))* &
2541!^ & (tl_Huon(i,j ,k)+ &
2542!^ & tl_Huon(i,j-1,k)- &
2543!^ & cff*(tl_Huee(i,j )+ &
2544!^ & tl_Huee(i,j-1))))
2545!^
2546 adfac=0.25_r8*ad_vfx(i,j)
2547 adfac1=adfac*(v(i ,j,k,nrhs)+ &
2548# ifdef WEC_MELLOR
2549 & v_stokes(i ,j,k)+ &
2550 & v_stokes(i-1,j,k)+ &
2551# endif
2552 & v(i-1,j,k,nrhs)- &
2553 & cff*(vxx(i ,j)+ &
2554 & vxx(i-1,j)))
2555 adfac2=adfac1*cff
2556 adfac3=adfac*(huon(i,j ,k)+ &
2557 & huon(i,j-1,k)- &
2558 & cff*(huee(i,j )+ &
2559 & huee(i,j-1)))
2560 adfac4=adfac3*cff
2561 ad_huon(i,j-1,k)=ad_huon(i,j-1,k)+adfac1
2562 ad_huon(i,j ,k)=ad_huon(i,j ,k)+adfac1
2563 ad_huee(i,j )=ad_huee(i,j )-adfac2
2564 ad_huee(i,j-1)=ad_huee(i,j-1)-adfac2
2565 ad_v(i-1,j,k,nrhs)=ad_v(i-1,j,k,nrhs)+adfac3
2566 ad_v(i ,j,k,nrhs)=ad_v(i ,j,k,nrhs)+adfac3
2567# ifdef WEC_MELLOR
2568 ad_v_stokes(i-1,j,k)=ad_v_stokes(i-1,j,k)+adfac3
2569 ad_v_stokes(i ,j,k)=ad_v_stokes(i ,j,k)+adfac3
2570# endif
2571 ad_vxx(i-1,j)=ad_vxx(i-1,j)-adfac4
2572 ad_vxx(i ,j)=ad_vxx(i ,j)-adfac4
2573 ad_vfx(i,j)=0.0_r8
2574 END DO
2575 END DO
2576# else
2577 DO j=jstrv,jend
2578 DO i=istr,iend+1
2579 cff1=v(i ,j,k,nrhs)+ &
2580# ifdef WEC_MELLOR
2581 & v_stokes(i ,j,k)+ &
2582 & v_stokes(i-1,j,k)+ &
2583# endif
2584 & v(i-1,j,k,nrhs)
2585 cff2=huon(i,j,k)+huon(i,j-1,k)
2586 IF (cff2.gt.0.0_r8) THEN
2587 cff=vxx(i-1,j)
2588 ELSE
2589 cff=vxx(i,j)
2590 END IF
2591!^ tl_VFx(i,j)=0.25_r8* &
2592!^ & ((tl_cff1+Gadv*tl_cff)* &
2593!^ & (cff2+Gadv*0.5_r8*(Huee(i,j )+ &
2594!^ & Huee(i,j-1)))+ &
2595!^ & (cff1+Gadv*cff)* &
2596!^ & (tl_cff2+Gadv*0.5_r8*(tl_Huee(i,j )+ &
2597!^ & tl_Huee(i,j-1))))
2598!^
2599 adfac=0.25_r8*ad_vfx(i,j)
2600 adfac1=adfac*(cff1+gadv*cff)
2601 adfac2=adfac1*gadv*0.5_r8
2602 adfac3=adfac*(cff2+gadv*0.5_r8*(huee(i,j )+ &
2603 & huee(i,j-1)))
2604 ad_huee(i,j-1)=ad_huee(i,j-1)+adfac2
2605 ad_huee(i,j )=ad_huee(i,j )+adfac2
2606 ad_cff2=ad_cff2+adfac1
2607 ad_cff1=ad_cff1+adfac3
2608 ad_cff=ad_cff+gadv*adfac3
2609 ad_vfx(i,j)=0.0_r8
2610 IF (cff2.gt.0.0_r8) THEN
2611!^ tl_cff=tl_vxx(i-1,j)
2612!^
2613 ad_vxx(i-1,j)=ad_vxx(i-1,j)+ad_cff
2614 ad_cff=0.0_r8
2615 ELSE
2616!^ tl_cff=tl_vxx(i,j)
2617!^
2618 ad_vxx(i,j)=ad_vxx(i,j)+ad_cff
2619 ad_cff=0.0_r8
2620 END IF
2621!^ tl_cff2=tl_Huon(i,j,k)+tl_Huon(i,j-1,k)
2622!^
2623 ad_huon(i,j-1,k)=ad_huon(i,j-1,k)+ad_cff2
2624 ad_huon(i,j ,k)=ad_huon(i,j ,k)+ad_cff2
2625 ad_cff2=0.0_r8
2626!^ tl_cff1=tl_v(i ,j,k,nrhs)+ &
2627# ifdef WEC_MELLOR
2628!^ & tl_v_stokes(i ,j,k)+ &
2629!^ & tl_v_stokes(i-1,j,k)+ &
2630# endif
2631!^ & tl_v(i-1,j,k,nrhs)
2632!^
2633 ad_v(i-1,j,k,nrhs)=ad_v(i-1,j,k,nrhs)+ad_cff1
2634 ad_v(i ,j,k,nrhs)=ad_v(i ,j,k,nrhs)+ad_cff1
2635# ifdef WEC_MELLOR
2636 ad_v_stokes(i-1,j,k)=ad_v_stokes(i-1,j,k)+ad_cff1
2637 ad_v_stokes(i ,j,k)=ad_v_stokes(i ,j,k)+ad_cff1
2638# endif
2639 ad_cff1=0.0_r8
2640 END DO
2641 END DO
2642# endif
2643 DO j=jstrv-1,jend
2644 DO i=istr,iend+1
2645!^ tl_Huee(i,j)=tl_Huon(i,j-1,k)-2.0_r8*tl_Huon(i,j,k)+ &
2646!^ & tl_Huon(i,j+1,k)
2647!^
2648 ad_huon(i,j-1,k)=ad_huon(i,j-1,k)+ad_huee(i,j)
2649 ad_huon(i,j ,k)=ad_huon(i,j ,k)-2.0_r8*ad_huee(i,j)
2650 ad_huon(i,j+1,k)=ad_huon(i,j+1,k)+ad_huee(i,j)
2651 ad_huee(i,j)=0.0_r8
2652 END DO
2653 END DO
2654 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2655 IF (domain(ng)%Eastern_Edge(tile)) THEN
2656 DO j=jstrv,jend
2657!^ tl_vxx(Iend+1,j)=tl_vxx(Iend,j)
2658!^
2659 ad_vxx(iend,j)=ad_vxx(iend,j)+ad_vxx(iend+1,j)
2660 ad_vxx(iend+1,j)=0.0_r8
2661 END DO
2662 END IF
2663 END IF
2664 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2665 IF (domain(ng)%Western_Edge(tile)) THEN
2666 DO j=jstrv,jend
2667!^ tl_vxx(Istr-1,j)=tl_vxx(Istr,j)
2668!^
2669 ad_vxx(istr,j)=ad_vxx(istr,j)+ad_vxx(istr-1,j)
2670 ad_vxx(istr-1,j)=0.0_r8
2671 END DO
2672 END IF
2673 END IF
2674 DO j=jstrv,jend
2675 DO i=istrm1,iendp1
2676!^ tl_vxx(i,j)=tl_v(i-1,j,k,nrhs)-2.0_r8*tl_v(i,j,k,nrhs)+ &
2677# ifdef WEC_MELLOR
2678!^ & tl_v_stokes(i-1,j,k)-2.0_r8*tl_v_stokes(i,j,k)+ &
2679!^ & tl_v_stokes(i+1,j,k)+ &
2680# endif
2681!^ & tl_v(i+1,j,k,nrhs)
2682!^
2683 ad_v(i-1,j,k,nrhs)=ad_v(i-1,j,k,nrhs)+ad_vxx(i,j)
2684 ad_v(i ,j,k,nrhs)=ad_v(i ,j,k,nrhs)-2.0_r8*ad_vxx(i,j)
2685 ad_v(i+1,j,k,nrhs)=ad_v(i+1,j,k,nrhs)+ad_vxx(i,j)
2686# ifdef WEC_MELLOR
2687 ad_v_stokes(i-1,j,k)=ad_v_stokes(i-1,j,k)+ad_vxx(i,j)
2688 ad_v_stokes(i ,j,k)=ad_v_stokes(i ,j,k)-2.0_r8*ad_vxx(i,j)
2689 ad_v_stokes(i+1,j,k)=ad_v_stokes(i+1,j,k)+ad_vxx(i,j)
2690# endif
2691 ad_vxx(i,j)=0.0_r8
2692 END DO
2693 END DO
2694 DO j=jstrm1,jendp1
2695 DO i=istru,iend
2696 uee(i,j)=u(i,j-1,k,nrhs)-2.0_r8*u(i,j,k,nrhs)+ &
2697# ifdef WEC_MELLOR
2698 & u_stokes(i,j-1,k)-2.0_r8*u_stokes(i,j,k)+ &
2699 & u_stokes(i,j+1,k)+ &
2700# endif
2701 & u(i,j+1,k,nrhs)
2702 END DO
2703 END DO
2704 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2705 IF (domain(ng)%Southern_Edge(tile)) THEN
2706 DO i=istru,iend
2707 uee(i,jstr-1)=uee(i,jstr)
2708 END DO
2709 END IF
2710 END IF
2711 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2712 IF (domain(ng)%Northern_Edge(tile)) THEN
2713 DO i=istru,iend
2714 uee(i,jend+1)=uee(i,jend)
2715 END DO
2716 END IF
2717 END IF
2718 DO j=jstr,jend+1
2719 DO i=istru-1,iend
2720 hvxx(i,j)=hvom(i-1,j,k)-2.0_r8*hvom(i,j,k)+hvom(i+1,j,k)
2721 END DO
2722 END DO
2723# ifdef UV_C4ADVECTION
2724!
2725! Fourth-order, centered differences u-momentum adjoint advection.
2726!
2727 cff=1.0_r8/6.0_r8
2728 DO j=jstr,jend+1
2729 DO i=istru,iend
2730!^ tl_UFe(i,j)=0.25_r8*((tl_u(i,j ,k,nrhs)+ &
2731# ifdef WEC_MELLOR
2732!^ & tl_u_stokes(i,j ,k)+ &
2733!^ & tl_u_stokes(i,j-1,k)+ &
2734# endif
2735!^ & tl_u(i,j-1,k,nrhs)- &
2736!^ & cff*(tl_uee (i,j )+ &
2737!^ & tl_uee (i,j-1)))* &
2738!^ & (Hvom(i ,j,k)+ &
2739!^ & Hvom(i-1,j,k)- &
2740!^ & cff*(Hvxx(i ,j)+ &
2741!^ & Hvxx(i-1,j)))+ &
2742!^ & (u(i,j ,k,nrhs)+ &
2743# ifdef WEC_MELLOR
2744!^ & u_stokes(i,j ,k)+ &
2745!^ & u_stokes(i,j-1,k)+ &
2746# endif
2747!^ & u(i,j-1,k,nrhs)- &
2748!^ & cff*(uee (i,j )+ &
2749!^ & uee (i,j-1)))* &
2750!^ & (tl_Hvom(i ,j,k)+ &
2751!^ & tl_Hvom(i-1,j,k)- &
2752!^ & cff*(tl_Hvxx(i ,j)+ &
2753!^ & tl_Hvxx(i-1,j))))
2754!^
2755 adfac=0.25_r8*ad_ufe(i,j)
2756 adfac1=adfac*(u(i,j ,k,nrhs)+ &
2757# ifdef WEC_MELLOR
2758 & u_stokes(i,j ,k)+ &
2759 & u_stokes(i,j-1,k)+ &
2760# endif
2761 & u(i,j-1,k,nrhs)- &
2762 & cff*(uee(i,j )+ &
2763 & uee(i,j-1)))
2764 adfac2=adfac1*cff
2765 adfac3=adfac*(hvom(i ,j,k)+ &
2766 & hvom(i-1,j,k)- &
2767 & cff*(hvxx(i ,j)+ &
2768 & hvxx(i-1,j)))
2769 adfac4=adfac3*cff
2770 ad_hvom(i-1,j,k)=ad_hvom(i-1,j,k)+adfac1
2771 ad_hvom(i ,j,k)=ad_hvom(i ,j,k)+adfac1
2772 ad_hvxx(i-1,j)=ad_hvxx(i-1,j)-adfac2
2773 ad_hvxx(i ,j)=ad_hvxx(i ,j)-adfac2
2774 ad_u(i,j-1,k,nrhs)=ad_u(i,j-1,k,nrhs)+adfac3
2775 ad_u(i,j ,k,nrhs)=ad_u(i,j ,k,nrhs)+adfac3
2776# ifdef WEC_MELLOR
2777 ad_u_stokes(i,j-1,k)=ad_u_stokes(i,j-1,k)+adfac3
2778 ad_u_stokes(i,j ,k)=ad_u_stokes(i,j ,k)+adfac3
2779# endif
2780 ad_uee(i,j-1)=ad_uee(i,j-1)-adfac4
2781 ad_uee(i,j )=ad_uee(i,j )-adfac4
2782 ad_ufe(i,j)=0.0_r8
2783 END DO
2784 END DO
2785# else
2786!
2787! Third-order, upstream bias u-momentum adjoint advection with velocity
2788! dependent hyperdiffusion.
2789!
2790 DO j=jstr,jend+1
2791 DO i=istru,iend
2792 cff1=u(i,j ,k,nrhs)+ &
2793# ifdef WEC_MELLOR
2794 & u_stokes(i,j ,k)+ &
2795 & u_stokes(i,j-1,k)+ &
2796# endif
2797 & u(i,j-1,k,nrhs)
2798 cff2=hvom(i,j,k)+hvom(i-1,j,k)
2799 IF (cff2.gt.0.0_r8) THEN
2800 cff=uee(i,j-1)
2801 ELSE
2802 cff=uee(i,j)
2803 END IF
2804!^ tl_UFe(i,j)=0.25_r8* &
2805!^ & ((tl_cff1+Gadv*tl_cff)* &
2806!^ & (cff2+Gadv*0.5_r8*(Hvxx(i ,j)+ &
2807!^ & Hvxx(i-1,j)))+ &
2808!^ & (cff1+Gadv*cff)* &
2809!^ & (tl_cff2+Gadv*0.5_r8*(tl_Hvxx(i ,j)+ &
2810!^ & tl_Hvxx(i-1,j))))
2811!^
2812 adfac=0.25_r8*ad_ufe(i,j)
2813 adfac1=adfac*(cff1+gadv*cff)
2814 adfac2=adfac1*gadv*0.5_r8
2815 adfac3=adfac*(cff2+gadv*0.5_r8*(hvxx(i ,j)+ &
2816 & hvxx(i-1,j)))
2817 ad_hvxx(i-1,j)=ad_hvxx(i-1,j)+adfac2
2818 ad_hvxx(i ,j)=ad_hvxx(i ,j)+adfac2
2819 ad_cff2=ad_cff2+adfac1
2820 ad_cff1=ad_cff1+adfac3
2821 ad_cff=ad_cff+gadv*adfac3
2822 ad_ufe(i,j)=0.0_r8
2823 IF (cff2.gt.0.0_r8) THEN
2824!^ tl_cff=tl_uee(i,j-1)
2825!^
2826 ad_uee(i,j-1)=ad_uee(i,j-1)+ad_cff
2827 ad_cff=0.0_r8
2828 ELSE
2829!^ tl_cff=tl_uee(i,j)
2830!^
2831 ad_uee(i,j)=ad_uee(i,j)+ad_cff
2832 ad_cff=0.0_r8
2833 END IF
2834!^ tl_cff2=tl_Hvom(i,j,k)+tl_Hvom(i-1,j,k)
2835!^
2836 ad_hvom(i-1,j,k)=ad_hvom(i-1,j,k)+ad_cff2
2837 ad_hvom(i ,j,k)=ad_hvom(i ,j,k)+ad_cff2
2838 ad_cff2=0.0_r8
2839!^ tl_cff1=tl_u(i,j,k,nrhs)+ &
2840# ifdef WEC_MELLOR
2841!^ & tl_u_stokes(i,j ,k)+ &
2842!^ & tl_u_stokes(i,j-1,k)+ &
2843# endif
2844!^ & tl_u(i,j-1,k,nrhs)
2845!^
2846 ad_u(i,j-1,k,nrhs)=ad_u(i,j-1,k,nrhs)+ad_cff1
2847 ad_u(i,j ,k,nrhs)=ad_u(i,j ,k,nrhs)+ad_cff1
2848# ifdef WEC_MELLOR
2849 ad_u_stokes(i,j-1,k)=ad_u_stokes(i,j-1,k)+ad_cff1
2850 ad_u_stokes(i,j ,k)=ad_u_stokes(i,j ,k)+ad_cff1
2851# endif
2852 ad_cff1=0.0_r8
2853 END DO
2854 END DO
2855# endif
2856 DO j=jstr,jend+1
2857 DO i=istru-1,iend
2858!^ tl_Hvxx(i,j)=tl_Hvom(i-1,j,k)-2.0_r8*tl_Hvom(i,j,k)+ &
2859!^ & tl_Hvom(i+1,j,k)
2860!^
2861 ad_hvom(i-1,j,k)=ad_hvom(i-1,j,k)+ad_hvxx(i,j)
2862 ad_hvom(i ,j,k)=ad_hvom(i ,j,k)-2.0_r8*ad_hvxx(i,j)
2863 ad_hvom(i+1,j,k)=ad_hvom(i+1,j,k)+ad_hvxx(i,j)
2864 ad_hvxx(i,j)=0.0_r8
2865 END DO
2866 END DO
2867 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2868 IF (domain(ng)%Northern_Edge(tile)) THEN
2869 DO i=istru,iend
2870!^ tl_uee(i,Jend+1)=tl_uee(i,Jend)
2871!^
2872 ad_uee(i,jend)=ad_uee(i,jend)+ad_uee(i,jend+1)
2873 ad_uee(i,jend+1)=0.0_r8
2874 END DO
2875 END IF
2876 END IF
2877 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2878 IF (domain(ng)%Southern_Edge(tile)) THEN
2879 DO i=istru,iend
2880!^ tl_uee(i,Jstr-1)=tl_uee(i,Jstr)
2881!^
2882 ad_uee(i,jstr)=ad_uee(i,jstr)+ad_uee(i,jstr-1)
2883 ad_uee(i,jstr-1)=0.0_r8
2884 END DO
2885 END IF
2886 END IF
2887 DO j=jstrm1,jendp1
2888 DO i=istru,iend
2889!^ tl_uee(i,j)=tl_u(i,j-1,k,nrhs)-2.0_r8*tl_u(i,j,k,nrhs)+ &
2890# ifdef WEC_MELLOR
2891!^ & tl_u_stokes(i,j-1,k)-2.0_r8*tl_u_stokes(i,j,k)+ &
2892!^ & tl_u_stokes(i,j+1,k)+ &
2893# endif
2894!^ & tl_u(i,j+1,k,nrhs)
2895!^
2896 ad_u(i,j-1,k,nrhs)=ad_u(i,j-1,k,nrhs)+ad_uee(i,j)
2897 ad_u(i,j ,k,nrhs)=ad_u(i,j ,k,nrhs)-2.0_r8*ad_uee(i,j)
2898 ad_u(i,j+1,k,nrhs)=ad_u(i,j+1,k,nrhs)+ad_uee(i,j)
2899# ifdef WEC_MELLOR
2900 ad_u_stokes(i,j-1,k)=ad_u_stokes(i,j-1,k)+ad_uee(i,j)
2901 ad_u_stokes(i,j ,k)=ad_u_stokes(i,j ,k)-2.0_r8*ad_uee(i,j)
2902 ad_u_stokes(i,j+1,k)=ad_u_stokes(i,j+1,k)+ad_uee(i,j)
2903# endif
2904 ad_uee(i,j)=0.0_r8
2905 END DO
2906 END DO
2907 DO j=jstr,jend
2908 DO i=istrum1,iendp1
2909 uxx(i,j)=u(i-1,j,k,nrhs)-2.0_r8*u(i,j,k,nrhs)+ &
2910# ifdef WEC_MELLOR
2911 & u_stokes(i-1,j,k)-2.0_r8*u_stokes(i,j,k)+ &
2912 & u_stokes(i+1,j,k)+ &
2913# endif
2914 & u(i+1,j,k,nrhs)
2915 huxx(i,j)=huon(i-1,j,k)-2.0_r8*huon(i,j,k)+huon(i+1,j,k)
2916 END DO
2917 END DO
2918 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2919 IF (domain(ng)%Western_Edge(tile)) THEN
2920 DO j=jstr,jend
2921 uxx(istr,j)=uxx(istr+1,j)
2922 huxx(istr,j)=huxx(istr+1,j)
2923 END DO
2924 END IF
2925 END IF
2926 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2927 IF (domain(ng)%Eastern_Edge(tile)) THEN
2928 DO j=jstr,jend
2929 uxx(iend+1,j)=uxx(iend,j)
2930 huxx(iend+1,j)=huxx(iend,j)
2931 END DO
2932 END IF
2933 END IF
2934# ifdef UV_C4ADVECTION
2935 cff=1.0_r8/6.0_r8
2936 DO j=jstr,jend
2937 DO i=istru-1,iend
2938!^ tl_UFx(i,j)=0.25_r8*((tl_u(i ,j,k,nrhs)+ &
2939# ifdef WEC_MELLOR
2940!^ & tl_u_stokes(i ,j,k)+ &
2941!^ & tl_u_stokes(i+1,j,k)+ &
2942# endif
2943!^ & tl_u(i+1,j,k,nrhs)- &
2944!^ & cff*(tl_uxx (i ,j)+ &
2945!^ & tl_uxx (i+1,j)))* &
2946!^ & (Huon(i ,j,k)+ &
2947!^ & Huon(i+1,j,k)- &
2948!^ & cff*(Huxx(i ,j)+ &
2949!^ & Huxx(i+1,j)))+ &
2950!^ & (u(i ,j,k,nrhs)+ &
2951# ifdef WEC_MELLOR
2952!^ & u_stokes(i ,j,k)+ &
2953!^ & u_stokes(i+1,j,k)+ &
2954# endif
2955!^ & u(i+1,j,k,nrhs)- &
2956!^ & cff*(uxx (i ,j)+ &
2957!^ & uxx (i+1,j)))* &
2958!^ & (tl_Huon(i ,j,k)+ &
2959!^ & tl_Huon(i+1,j,k)- &
2960!^ & cff*(tl_Huxx(i ,j)+ &
2961!^ & tl_Huxx(i+1,j))))
2962!^
2963 adfac=0.25_r8*ad_ufx(i,j)
2964 adfac1=adfac*(u(i ,j,k,nrhs)+ &
2965# ifdef WEC_MELLOR
2966 & u_stokes(i ,j,k)+ &
2967 & u_stokes(i+1,j,k)+ &
2968# endif
2969 & u(i+1,j,k,nrhs)- &
2970 & cff*(uxx(i ,j)+ &
2971 & uxx(i+1,j)))
2972 adfac2=adfac1*cff
2973 adfac3=adfac*(huon(i ,j,k)+ &
2974 & huon(i+1,j,k)- &
2975 & cff*(huxx(i ,j)+ &
2976 & huxx(i+1,j)))
2977 adfac4=adfac3*cff
2978 ad_huon(i ,j,k)=ad_huon(i ,j,k)+adfac1
2979 ad_huon(i+1,j,k)=ad_huon(i+1,j,k)+adfac1
2980 ad_huxx(i ,j)=ad_huxx(i ,j)-adfac2
2981 ad_huxx(i+1,j)=ad_huxx(i+1,j)-adfac2
2982 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)+adfac3
2983 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+adfac3
2984# ifdef WEC_MELLOR
2985 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)+adfac3
2986 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+adfac3
2987# endif
2988 ad_uxx(i ,j)=ad_uxx(i ,j)-adfac4
2989 ad_uxx(i+1,j)=ad_uxx(i+1,j)-adfac4
2990 ad_ufx(i,j)=0.0_r8
2991 END DO
2992 END DO
2993# else
2994 DO j=jstr,jend
2995 DO i=istru-1,iend
2996 cff1=u(i ,j,k,nrhs)+ &
2997# ifdef WEC_MELLOR
2998 & u_stokes(i ,j,k)+ &
2999 & u_stokes(i+1,j,k)+ &
3000# endif
3001 & u(i+1,j,k,nrhs)
3002 IF (cff1.gt.0.0_r8) THEN
3003 cff=uxx(i,j)
3004 ELSE
3005 cff=uxx(i+1,j)
3006 END IF
3007!^ tl_UFx(i,j)=0.25_r8* &
3008!^ & ((tl_cff1+Gadv*tl_cff)* &
3009!^ & (Huon(i ,j,k)+ &
3010!^ & Huon(i+1,j,k)+ &
3011!^ & Gadv*0.5_r8*(Huxx(i ,j)+ &
3012!^ & Huxx(i+1,j)))+ &
3013!^ & (cff1+Gadv*cff)* &
3014!^ & (tl_Huon(i ,j,k)+ &
3015!^ & tl_Huon(i+1,j,k)+ &
3016!^ & Gadv*0.5_r8*(tl_Huxx(i ,j)+ &
3017!^ & tl_Huxx(i+1,j))))
3018!^
3019 adfac=0.25_r8*ad_ufx(i,j)
3020 adfac1=adfac*(cff1+gadv*cff)
3021 adfac2=adfac1*gadv*0.5_r8
3022 adfac3=adfac*(huon(i ,j,k)+ &
3023 & huon(i+1,j,k)+ &
3024 & gadv*0.5_r8*(huxx(i ,j)+ &
3025 & huxx(i+1,j)))
3026 ad_huon(i ,j,k)=ad_huon(i ,j,k)+adfac1
3027 ad_huon(i+1,j,k)=ad_huon(i+1,j,k)+adfac1
3028 ad_huxx(i ,j)=ad_huxx(i ,j)+adfac2
3029 ad_huxx(i+1,j)=ad_huxx(i+1,j)+adfac2
3030 ad_cff1=ad_cff1+adfac3
3031 ad_cff=ad_cff+gadv*adfac3
3032 ad_ufx(i,j)=0.0_r8
3033 IF (cff1.gt.0.0_r8) THEN
3034!^ tl_cff=tl_uxx(i,j)
3035!^
3036 ad_uxx(i,j)=ad_uxx(i,j)+ad_cff
3037 ad_cff=0.0_r8
3038 ELSE
3039!^ tl_cff=tl_uxx(i+1,j)
3040!^
3041 ad_uxx(i+1,j)=ad_uxx(i+1,j)+ad_cff
3042 ad_cff=0.0_r8
3043 END IF
3044!^ tl_cff1=tl_u(i ,j,k,nrhs)+ &
3045# ifdef WEC_MELLOR
3046!^ & tl_u_stokes(i ,j,k)+ &
3047!^ & tl_u_stokes(i+1,j,k)+ &
3048# endif
3049!^ & tl_u(i+1,j,k,nrhs)
3050!^
3051 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)+ad_cff1
3052 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+ad_cff1
3053# ifdef WEC_MELLOR
3054 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)+ad_cff1
3055 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+ad_cff1
3056# endif
3057 ad_cff1=0.0_r8
3058 END DO
3059 END DO
3060# endif
3061 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3062 IF (domain(ng)%Eastern_Edge(tile)) THEN
3063 DO j=jstr,jend
3064!^ tl_Huxx(Iend+1,j)=tl_Huxx(Iend,j)
3065!^
3066 ad_huxx(iend,j)=ad_huxx(iend,j)+ad_huxx(iend+1,j)
3067 ad_huxx(iend+1,j)=0.0_r8
3068!^ tl_uxx (Iend+1,j)=tl_uxx (Iend,j)
3069!^
3070 ad_uxx(iend,j)=ad_uxx(iend,j)+ad_uxx(iend+1,j)
3071 ad_uxx(iend+1,j)=0.0_r8
3072 END DO
3073 END IF
3074 END IF
3075 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3076 IF (domain(ng)%Western_Edge(tile)) THEN
3077 DO j=jstr,jend
3078!^ tl_Huxx(Istr,j)=tl_Huxx(Istr+1,j)
3079!^
3080 ad_huxx(istr+1,j)=ad_huxx(istr+1,j)+ad_huxx(istr,j)
3081 ad_huxx(istr,j)=0.0_r8
3082!^ tl_uxx (Istr,j)=tl_uxx (Istr+1,j)
3083!^
3084 ad_uxx(istr+1,j)=ad_uxx(istr+1,j)+ad_uxx(istr,j)
3085 ad_uxx(istr ,j)=0.0_r8
3086 END DO
3087 END IF
3088 END IF
3089 DO j=jstr,jend
3090 DO i=istrum1,iendp1
3091!^ tl_Huxx(i,j)=tl_Huon(i-1,j,k)-2.0_r8*tl_Huon(i,j,k)+ &
3092!^ & tl_Huon(i+1,j,k)
3093!^
3094 ad_huon(i-1,j,k)=ad_huon(i-1,j,k)+ad_huxx(i,j)
3095 ad_huon(i ,j,k)=ad_huon(i ,j,k)-2.0_r8*ad_huxx(i,j)
3096 ad_huon(i+1,j,k)=ad_huon(i+1,j,k)+ad_huxx(i,j)
3097 ad_huxx(i,j)=0.0_r8
3098!^ tl_uxx(i,j)=tl_u(i-1,j,k,nrhs)-2.0_r8*tl_u(i,j,k,nrhs)+ &
3099# ifdef WEC_MELLOR
3100!^ & tl_u_stokes(i-1,j,k)-2.0_r8*tl_u_stokes(i,j,k)+ &
3101!^ & tl_u_stokes(i+1,j,k)
3102# endif
3103!^ & tl_u(i+1,j,k,nrhs)
3104!^
3105 ad_u(i-1,j,k,nrhs)=ad_u(i-1,j,k,nrhs)+ad_uxx(i,j)
3106 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)-2.0_r8*ad_uxx(i,j)
3107 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+ad_uxx(i,j)
3108# ifdef WEC_MELLOR
3109 ad_u_stokes(i-1,j,k)=ad_u_stokes(i-1,j,k)+ad_uxx(i,j)
3110 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)-2.0_r8*ad_uxx(i,j)
3111 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+ad_uxx(i,j)
3112# endif
3113 ad_uxx(i,j)=0.0_r8
3114 END DO
3115 END DO
3116# endif
3117# endif
3118!
3119!-----------------------------------------------------------------------
3120! Add in nudging of 3D momentum climatology.
3121!-----------------------------------------------------------------------
3122!
3123 IF (lnudgem3clm(ng)) THEN
3124 DO j=jstrv,jend
3125 DO i=istr,iend
3126 cff=0.25_r8*(clima(ng)%M3nudgcof(i,j-1,k)+ &
3127 & clima(ng)%M3nudgcof(i,j ,k))* &
3128 & om_v(i,j)*on_v(i,j)
3129!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)+ &
3130!^ & cff*((Hz(i,j-1,k)+Hz(i,j,k))* &
3131!^ & (-tl_v(i,j,k,nrhs))+ &
3132!^ & (tl_Hz(i,j-1,k)+tl_Hz(i,j,k))* &
3133!^ & (CLIMA(ng)%vclm(i,j,k)-
3134!^ & v(i,j,k,nrhs)))
3135!^
3136 adfac=cff*ad_rv(i,j,k,nrhs)
3137 adfac1=adfac*(clima(ng)%vclm(i,j,k)-v(i,j,k,nrhs))
3138 ad_hz(i,j-1,k)=ad_hz(i,j-1,k)+adfac1
3139 ad_hz(i,j ,k)=ad_hz(i,j ,k)+adfac1
3140 ad_v(i,j,k,nrhs)=ad_v(i,j,k,nrhs)- &
3141 & (hz(i,j-1,k)+hz(i,j,k))*adfac
3142 END DO
3143 END DO
3144 DO j=jstr,jend
3145 DO i=istru,iend
3146 cff=0.25_r8*(clima(ng)%M3nudgcof(i-1,j,k)+ &
3147 & clima(ng)%M3nudgcof(i ,j,k))* &
3148 & om_u(i,j)*on_u(i,j)
3149!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)+ &
3150!^ & cff*((Hz(i-1,j,k)+Hz(i,j,k))* &
3151!^ & (-tl_u(i,j,k,nrhs))+ &
3152!^ & (tl_Hz(i-1,j,k)+tl_Hz(i,j,k))* &
3153!^ & (CLIMA(ng)%uclm(i,j,k)-
3154!^ & u(i,j,k,nrhs)))
3155!^
3156 adfac=cff*ad_ru(i,j,k,nrhs)
3157 adfac1=adfac*(clima(ng)%uclm(i,j,k)-u(i,j,k,nrhs))
3158 ad_hz(i-1,j,k)=ad_hz(i-1,j,k)+adfac1
3159 ad_hz(i ,j,k)=ad_hz(i ,j,k)+adfac1
3160 ad_u(i,j,k,nrhs)=ad_u(i,j,k,nrhs)- &
3161 & (hz(i-1,j,k)+hz(i,j,k))*adfac
3162 END DO
3163 END DO
3164 END IF
3165
3166# if defined CURVGRID && defined UV_ADV
3167!
3168!-----------------------------------------------------------------------
3169! Add in curvilinear transformation terms.
3170!-----------------------------------------------------------------------
3171!
3172 DO j=jstrv,jend
3173 DO i=istr,iend
3174# ifdef DIAGNOSTICS_UV
3175!! DiaRV(i,j,k,nrhs,M3hadv)=-cff1
3176!! DiaRV(i,j,k,nrhs,M3yadv)=-cff2
3177!! DiaRV(i,j,k,nrhs,M3xadv)=-cff1+cff2
3178!! cff2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
3179# endif
3180!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)-tl_cff1
3181!^
3182 ad_cff1=ad_cff1-ad_rv(i,j,k,nrhs)
3183!^ tl_cff1=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
3184!^
3185 adfac=0.5_r8*ad_cff1
3186 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
3187 ad_vfe(i,j )=ad_vfe(i,j )+adfac
3188 ad_cff1=0.0_r8
3189 END DO
3190 END DO
3191 DO j=jstr,jend
3192 DO i=istru,iend
3193# ifdef DIAGNOSTICS_UV
3194!! DiaRU(i,j,k,nrhs,M3hadv)=cff1
3195!! DiaRU(i,j,k,nrhs,M3yadv)=cff2
3196!! DiaRU(i,j,k,nrhs,M3xadv)=cff1-cff2
3197!! cff2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
3198# endif
3199!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)+tl_cff1
3200!^
3201 ad_cff1=ad_cff1+ad_ru(i,j,k,nrhs)
3202!^ tl_cff1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
3203!^
3204 adfac=0.5_r8*ad_cff1
3205 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
3206 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
3207 ad_cff1=0.0_r8
3208 END DO
3209 END DO
3210 DO j=jstrv-1,jend
3211 DO i=istru-1,iend
3212 cff1=0.5_r8*(v(i,j ,k,nrhs)+ &
3213# ifdef WEC_MELLOR
3214 & v_stokes(i,j ,k)+ &
3215 & v_stokes(i,j+1,k)+ &
3216# endif
3217 & v(i,j+1,k,nrhs))
3218 cff2=0.5_r8*(u(i ,j,k,nrhs)+ &
3219# ifdef WEC_MELLOR
3220 & u_stokes(i ,j,k)+ &
3221 & u_stokes(i+1,j,k)+ &
3222# endif
3223 & u(i+1,j,k,nrhs))
3224 cff3=cff1*dndx(i,j)
3225 cff4=cff2*dmde(i,j)
3226 cff=hz(i,j,k)*(cff3-cff4)
3227# if defined DIAGNOSTICS_UV
3228!! Vwrk(i,j)=-cff*cff2 ! v equation, ETA-term
3229!! Uwrk(i,j)=-cff*cff1 ! u equation, ETA-term
3230!! cff=Hz(i,j,k)*cff4
3231# endif
3232!^ tl_VFe(i,j)=tl_cff*cff2+cff*tl_cff2
3233!^ tl_UFx(i,j)=tl_cff*cff1+cff*tl_cff1
3234!^
3235 ad_cff=ad_cff+ &
3236 & cff1*ad_ufx(i,j)+ &
3237 & cff2*ad_vfe(i,j)
3238 ad_cff1=ad_cff1+cff*ad_ufx(i,j)
3239 ad_cff2=ad_cff2+cff*ad_vfe(i,j)
3240 ad_ufx(i,j)=0.0_r8
3241 ad_vfe(i,j)=0.0_r8
3242!^ tl_cff=tl_Hz(i,j,k)*(cff3-cff4)+ &
3243!^ & Hz(i,j,k)*(tl_cff3-tl_cff4)
3244!^
3245 adfac=hz(i,j,k)*ad_cff
3246 ad_cff3=ad_cff3+adfac
3247 ad_cff4=ad_cff4-adfac
3248 ad_hz(i,j,k)=ad_hz(i,j,k)+(cff3-cff4)*ad_cff
3249 ad_cff=0.0_r8
3250!^ tl_cff4=tl_cff2*dmde(i,j)
3251!^
3252 ad_cff2=ad_cff2+dmde(i,j)*ad_cff4
3253 ad_cff4=0.0_r8
3254!^ tl_cff3=tl_cff1*dndx(i,j)
3255!^
3256 ad_cff1=ad_cff1+dndx(i,j)*ad_cff3
3257 ad_cff3=0.0_r8
3258!^ tl_cff2=0.5_r8*(tl_u(i ,j,k,nrhs)+ &
3259# ifdef WEC_MELLOR
3260!^ & tl_u_stokes(i ,j,k)+ &
3261!^ & tl_u_stokes(i+1,j,k)+ &
3262# endif
3263!^ & tl_u(i+1,j,k,nrhs))
3264!^
3265 adfac=0.5_r8*ad_cff2
3266 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)+adfac
3267 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+adfac
3268# ifdef WEC_MELLOR
3269 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)+adfac
3270 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+adfac
3271# endif
3272 ad_cff2=0.0_r8
3273!^ tl_cff1=0.5_r8*(tl_v(i,j ,k,nrhs)+ &
3274# ifdef WEC_MELLOR
3275!^ & tl_v_stokes(i,j ,k)+ &
3276!^ & tl_v_stokes(i,j+1,k)+ &
3277# endif
3278!^ & tl_v(i,j+1,k,nrhs))
3279!^
3280 adfac=0.5_r8*ad_cff1
3281 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)+adfac
3282 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+adfac
3283# ifdef WEC_MELLOR
3284 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)+adfac
3285 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+adfac
3286# endif
3287 ad_cff1=0.0_r8
3288 END DO
3289 END DO
3290# endif
3291# ifdef UV_COR
3292!
3293!-----------------------------------------------------------------------
3294! Add in Coriolis terms.
3295!-----------------------------------------------------------------------
3296!
3297 DO j=jstrv,jend
3298 DO i=istr,iend
3299# ifdef DIAGNOSTICS_UV
3300!! DiaRV(i,j,k,nrhs,M3fcor)=-cff1
3301# endif
3302!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)-tl_cff1
3303!^
3304 ad_cff1=ad_cff1-ad_rv(i,j,k,nrhs)
3305!^ tl_cff1=0.5_r8*(tl_VFe(i,j)+tl_VFe(i,j-1))
3306!^
3307 adfac=0.5_r8*ad_cff1
3308 ad_vfe(i,j-1)=ad_vfe(i,j-1)+adfac
3309 ad_vfe(i,j )=ad_vfe(i,j )+adfac
3310 ad_cff1=0.0_r8
3311 END DO
3312 END DO
3313 DO j=jstr,jend
3314 DO i=istru,iend
3315# ifdef DIAGNOSTICS_UV
3316!! DiaRU(i,j,k,nrhs,M3fcor)=cff1
3317# endif
3318!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)+tl_cff1
3319!^
3320 ad_cff1=ad_cff1+ad_ru(i,j,k,nrhs)
3321!^ tl_cff1=0.5_r8*(tl_UFx(i,j)+tl_UFx(i-1,j))
3322!^
3323 adfac=0.5_r8*ad_cff1
3324 ad_ufx(i-1,j)=ad_ufx(i-1,j)+adfac
3325 ad_ufx(i ,j)=ad_ufx(i ,j)+adfac
3326 ad_cff1=0.0_r8
3327 END DO
3328 END DO
3329 DO j=jstrv-1,jend
3330 DO i=istru-1,iend
3331 cff=0.5_r8*hz(i,j,k)*fomn(i,j)
3332!^ tl_VFe(i,j)=tl_cff*(u(i ,j,k,nrhs)+ &
3333# ifdef WEC_MELLOR
3334!^ & u_stokes(i ,j,k)+ &
3335!^ & u_stokes(i+1,j,k)+ &
3336# endif
3337!^ & u(i+1,j,k,nrhs))+ &
3338!^ & cff*(tl_u(i ,j,k,nrhs)+ &
3339# ifdef WEC_MELLOR
3340!^ & tl_u_stokes(i ,j,k)+ &
3341!^ & tl_u_stokes(i+1,j,k)+ &
3342# endif
3343!^ & tl_u(i+1,j,k,nrhs))
3344!^
3345 adfac=cff*ad_vfe(i,j)
3346 ad_u(i ,j,k,nrhs)=ad_u(i ,j,k,nrhs)+adfac
3347 ad_u(i+1,j,k,nrhs)=ad_u(i+1,j,k,nrhs)+adfac
3348# ifdef WEC_MELLOR
3349 ad_u_stokes(i ,j,k)=ad_u_stokes(i ,j,k)+adfac
3350 ad_u_stokes(i+1,j,k)=ad_u_stokes(i+1,j,k)+adfac
3351# endif
3352 ad_cff=ad_cff+(u(i ,j,k,nrhs)+ &
3353# ifdef WEC_MELLOR
3354 & u_stokes(i ,j,k)+ &
3355 & u_stokes(i+1,j,k)+ &
3356# endif
3357 & u(i+1,j,k,nrhs))*ad_vfe(i,j)
3358 ad_vfe(i,j)=0.0_r8
3359!^ tl_UFx(i,j)=tl_cff*(v(i,j ,k,nrhs)+ &
3360# ifdef WEC_MELLOR
3361!^ & v_stokes(i,j ,k)+ &
3362!^ & v_stokes(i,j+1,k)+ &
3363# endif
3364!^ & v(i,j+1,k,nrhs))+ &
3365!^ & cff*(tl_v(i,j ,k,nrhs)+ &
3366# ifdef WEC_MELLOR
3367!^ & tl_v_stokes(i,j ,k)+ &
3368!^ & tl_v_stokes(i,j+1,k)+ &
3369# endif
3370!^ & tl_v(i,j+1,k,nrhs))
3371!^
3372 adfac=cff*ad_ufx(i,j)
3373 ad_v(i,j ,k,nrhs)=ad_v(i,j ,k,nrhs)+adfac
3374 ad_v(i,j+1,k,nrhs)=ad_v(i,j+1,k,nrhs)+adfac
3375# ifdef WEC_MELLOR
3376 ad_v_stokes(i,j ,k)=ad_v_stokes(i,j ,k)+adfac
3377 ad_v_stokes(i,j+1,k)=ad_v_stokes(i,j+1,k)+adfac
3378# endif
3379 ad_cff=ad_cff+(v(i,j ,k,nrhs)+ &
3380# ifdef WEC_MELLOR
3381 & v_stokes(i,j ,k)+ &
3382 & v_stokes(i,j+1,k)+ &
3383# endif
3384 & v(i,j+1,k,nrhs))*ad_ufx(i,j)
3385 ad_ufx(i,j)=0.0_r8
3386!^ tl_cff=0.5_r8*tl_Hz(i,j,k)*fomn(i,j)
3387!^
3388 ad_hz(i,j,k)=ad_hz(i,j,k)+ &
3389 & 0.5_r8*fomn(i,j)*ad_cff
3390 ad_cff=0.0_r8
3391 END DO
3392 END DO
3393# endif
3394 END DO k_loop
3395# ifdef BODYFORCE
3396!
3397!-----------------------------------------------------------------------
3398! Apply adjoint bottom stress as a bodyforce: determine the thickness
3399! (m) of the bottom layer; then add in bottom stress as a bodyfoce.
3400!-----------------------------------------------------------------------
3401!
3402 DO j=jstrv-1,jend
3403 DO i=istru-1,iend
3404 wrk(i,j)=0.0_r8
3405 END DO
3406 END DO
3407 DO k=1,levbfrc(ng)
3408 DO j=jstrv-1,jend
3409 DO i=istru-1,iend
3410 wrk(i,j)=wrk(i,j)+hz(i,j,k)
3411 END DO
3412 END DO
3413 END DO
3414 DO k=1,levbfrc(ng)
3415 DO j=jstrv,jend
3416 DO i=istr,iend
3417# ifdef DIAGNOSTICS_UV
3418!! DiaRVfrc(i,j,3,M2bstr)=DiaRVfrc(i,j,3,M2bstr)-cff
3419!! DiaRV(i,j,k,nrhs,M3vvis)=DiaRV(i,j,k,nrhs,M3vvis)-cff
3420# endif
3421!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)-tl_cff
3422!^
3423 ad_cff=ad_cff-ad_rv(i,j,k,nrhs)
3424!^ tl_cff=tl_Vwrk(i,j)*(Hz(i,j ,k)+ &
3425!^ & Hz(i,j-1,k))+ &
3426!^ & Vwrk(i,j)*(tl_Hz(i,j ,k)+ &
3427!^ & tl_Hz(i,j-1,k))
3428!^
3429 adfac=vwrk(i,j)*ad_cff
3430 ad_hz(i,j-1,k)=ad_hz(i,j-1,k)+adfac
3431 ad_hz(i,j ,k)=ad_hz(i,j ,k)+adfac
3432 ad_vwrk(i,j)=ad_vwrk(i,j)+(hz(i,j ,k)+
3433 & hz(i,j-1,k))*ad_cff
3434 ad_cff=0.0_r8
3435 END DO
3436 END DO
3437 DO j=jstr,jend
3438 DO i=istru,iend
3439# ifdef DIAGNOSTICS_UV
3440!! DiaRUfrc(i,j,3,M2bstr)=DiaRUfrc(i,j,3,M2bstr)-cff
3441!! DiaRU(i,j,k,nrhs,M3vvis)=DiaRU(i,j,k,nrhs,M3vvis)-cff
3442# endif
3443!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)-tl_cff
3444!^
3445 ad_cff=ad_cff-ad_ru(i,j,k,nrhs)
3446!^ tl_cff=tl_Uwrk(i,j)*(Hz(i ,j,k)+ &
3447!^ & Hz(i-1,j,k))+ &
3448!^ & Uwrk(i,j)*(tl_Hz(i ,j,k)+ &
3449!^ & tl_Hz(i-1,j,k))
3450!^
3451 adfac=uwrk(i,j)*ad_cff
3452 ad_hz(i-1,j,k)=ad_hz(i-1,j,k)+adfac
3453 ad_hz(i ,j,k)=ad_hz(i ,j,k)+adfac
3454 ad_uwrk(i,j)=ad_uwrk(i,j)+(hz(i ,j,k)+ &
3455 & hz(i-1,j,k))*ad_cff
3456 ad_cff=0.0_r8
3457 END DO
3458 END DO
3459 END DO
3460 DO j=jstrv,jend
3461 DO i=istr,iend
3462 cff=0.25_r8*(pm(i,j-1)+pm(i,j))* &
3463 & (pn(i,j-1)+pn(i,j))
3464 cff1=1.0_r8/(cff*(wrk(i,j-1)+wrk(i,j)))
3465 vwrk(i,j)=bvstr(i,j)*cff1
3466!^ tl_Vwrk(i,j)=tl_bvstr(i,j)*cff1+ &
3467!^ & bvstr(i,j)*tl_cff1
3468!^
3469 ad_cff1=ad_cff+bvstr(i,j)*ad_vwrk(i,j)
3470 ad_bvstr(i,j)=tl_bvstr(i,j)+cff1*ad_vwrk(i,j)
3471 ad_vwrk(i,j)=0.0_r8
3472!^ tl_cff1=-cff1*cff1*cff*(tl_wrk(i,j-1)+tl_wrk(i,j))
3473!^
3474 adfac=-cff1*cff1*cff*ad_cff1
3475 ad_wrk(i,j )=ad_wrk(i,j )+adfac
3476 ad_wrk(i,j-1)=ad_wrk(i,j-1)+adfac
3477 ad_cff1=0.0_r8
3478 END DO
3479 END DO
3480 DO j=jstr,jend
3481 DO i=istru,iend
3482 cff=0.25_r8*(pm(i-1,j)+pm(i,j))* &
3483 & (pn(i-1,j)+pn(i,j))
3484 cff1=1.0_r8/(cff*(wrk(i-1,j)+wrk(i,j)))
3485 uwrk(i,j)=bustr(i,j)*cff1
3486!^ tl_Uwrk(i,j)=tl_bustr(i,j)*cff1+ &
3487!^ & bustr(i,j)*tl_cff1
3488!^
3489 ad_cff1=ad_cff1+bustr(i,j)*ad_uwrk(i,j)
3490 ad_bustr(i,j)=ad_bustr(i,j)+cff1*ad_uwrk(i,j)
3491 ad_uwrk(i,j)=0.0_r8
3492!^ tl_cff1=-cff1*cff1*cff*(tl_wrk(i-1,j)+tl_wrk(i,j))
3493!^
3494 adfac=-cff1*cff1*cff*ad_cff1
3495 ad_wrk(i-1,j)=ad_wrk(i-1,j)+adfac
3496 ad_wrk(i ,j)=ad_wrk(i ,j)+adfac
3497 ad_cff=0.0_r8
3498 END DO
3499 END DO
3500 DO k=1,levbfrc(ng)
3501 DO j=jstrv-1,jend
3502 DO i=istru-1,iend
3503!^ tl_wrk(i,j)=tl_wrk(i,j)+tl_Hz(i,j,k)
3504!^
3505 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_wrk(i,j)
3506 ad_wrk(i,j)=0.0_r8
3507 END DO
3508 END DO
3509 END DO
3510 DO j=jstrv-1,jend
3511 DO i=istru-1,iend
3512!^ tl_wrk(i,j)=0.0_r8
3513!^
3514 ad_wrk(i,j)=0.0_r8
3515 END DO
3516 END DO
3517!
3518!-----------------------------------------------------------------------
3519! Apply adjoint surface stress as a bodyforce: determine the thickness
3520! (m) of the surface layer; then add in surface stress as a bodyfoce.
3521!-----------------------------------------------------------------------
3522!
3523 DO j=jstrv-1,jend
3524 DO i=istru-1,iend
3525 wrk(i,j)=0.0_r8
3526 END DO
3527 END DO
3528 DO k=n(ng),levsfrc(ng),-1
3529 DO j=jstrv-1,jend
3530 DO i=istru-1,iend
3531 wrk(i,j)=wrk(i,j)+hz(i,j,k)
3532 END DO
3533 END DO
3534 END DO
3535 DO k=levsfrc(ng),n(ng)
3536 DO j=jstrv,jend
3537 DO i=istr,iend
3538# ifdef DIAGNOSTICS_UV
3539!! DiaRVfrc(i,j,3,M2sstr)=DiaRVfrc(i,j,3,M2sstr)+cff
3540!! DiaRV(i,j,k,nrhs,M3vvis)=DiaRV(i,j,k,nrhs,M3vvis)+cff
3541# endif
3542!^ tl_rv(i,j,k,nrhs)=tl_rv(i,j,k,nrhs)+tl_cff
3543!^
3544 ad_cff=ad_cff+tl_rv(i,j,k,nrhs)
3545!^ tl_cff=tl_Vwrk(i,j)*(Hz(i,j ,k)+ &
3546!^ & Hz(i,j-1,k))+ &
3547!^ & Vwrk(i,j)*(tl_Hz(i,j ,k)+ &
3548!^ & tl_Hz(i,j-1,k))
3549!^
3550 adfac=vwrk(i,j)*ad_cff
3551 ad_hz(i,j-1,k)=ad_hz(i,j-1,k)+adfac
3552 ad_hz(i,j ,k)=ad_hz(i,j ,k)+adfac
3553 ad_vwrk(i,j)=ad_vwrk(i,j)+(hz(i,j ,k)+ &
3554 & hz(i,j-1,k))*ad_cff
3555 ad_cff=0.0_r8
3556 END DO
3557 END DO
3558 DO j=jstr,jend
3559 DO i=istru,iend
3560# ifdef DIAGNOSTICS_UV
3561!! DiaRUfrc(i,j,3,M2sstr)=DiaRUfrc(i,j,3,M2sstr)+cff
3562!! DiaRU(i,j,k,nrhs,M3vvis)=DiaRU(i,j,k,nrhs,M3vvis)+cff
3563# endif
3564!^ tl_ru(i,j,k,nrhs)=tl_ru(i,j,k,nrhs)+tl_cff
3565!^
3566 ad_cff=ad_cff+tl_ru(i,j,k,nrhs)
3567!^ tl_cff=tl_Uwrk(i,j)*(Hz(i ,j,k)+ &
3568!^ & Hz(i-1,j,k))+ &
3569!^ & Uwrk(i,j)*(tl_Hz(i ,j,k)+ &
3570!^ & tl_Hz(i-1,j,k))
3571!^
3572 adfac=uwrk(i,j)*ad_cff
3573 ad_hz(i-1,j,k)=ad_hz(i-1,j,k)+adfac
3574 ad_hz(i ,j,k)=ad_hz(i ,j,k)+adfac
3575 ad_uwrk(i,j)=ad_uwrk(i,j)+(hz(i ,j,k)+ &
3576 & hz(i-1,j,k))*ad_fac
3577 ad_fac=0.0_r8
3578 END DO
3579 END DO
3580 END DO
3581 DO j=jstrv,jend
3582 DO i=istr,iend
3583 cff=0.25*(pm(i,j-1)+pm(i,j))* &
3584 & (pn(i,j-1)+pn(i,j))
3585 cff1=1.0_r8/(cff*(tl_wrk(i,j-1)+tl_wrk(i,j)))
3586 vwrk(i,j)=svstr(i,j)*cff1
3587!^ tl_Vwrk(i,j)=tl_svstr(i,j)*cff1+ &
3588!^ & svstr(i,j)*tl_cff1
3589!^
3590 ad_cff1=ad_cff1+svstr(i,j)*ad_vwrk(i,j)
3591 ad_svstr(i,j)=ad_svstr(i,j)+cff1*ad_vwrk(i,j)
3592 ad_vwrk(i,j)=0.0_r8
3593!^ tl_cff1=-cff1*cff1*cff*(tl_wrk(i,j-1)+tl_wrk(i,j))
3594!^
3595 adfac=-cff1*cff1*cff*ad_cff1
3596 ad_wrk(i,j-1)=ad_wrk(i,j-1)+adfac
3597 ad_wrk(i,j )=ad_wrk(i,j )+adfac
3598 ad_cff1=0.0_r8
3599 END DO
3600 END DO
3601 DO j=jstr,jend
3602 DO i=istru,iend
3603 cff=0.25_r8*(pm(i-1,j)+pm(i,j))* &
3604 & (pn(i-1,j)+pn(i,j))
3605 cff1=1.0_r8/(cff*(wrk(i-1,j)+wrk(i,j)))
3606 uwrk(i,j)=sustr(i,j)*cff1
3607!^ tl_Uwrk(i,j)=tl_sustr(i,j)*cff1+ &
3608!^ & sustr(i,j)*tl_cff1
3609!^
3610 ad_cff1=ad_cff1+sustr(i,j)*ad_uwrk(i,j)
3611 ad_sustr(i,j)=ad_sustr(i,j)+cff1*ad_uwrk(i,j)
3612 ad_uwrk(i,j)=0.0_r8
3613!^ tl_cff1=-cff1*cff1*cff*(tl_wrk(i-1,j)+tl_wrk(i,j))
3614!^
3615 adfac=-cff1*cff1*cff*ad_cff1
3616 ad_wrk(i-1,j)=ad_wrk(i-1,j)+adfac
3617 ad_wrk(i ,j)=ad_wrk(i ,j)+adfac
3618 ad_cff1=0.0_r8
3619 END DO
3620 END DO
3621 DO k=n(ng),levsfrc(ng),-1
3622 DO j=jstrv-1,jend
3623 DO i=istru-1,iend
3624!^ tl_wrk(i,j)=tl_wrk(i,j)+tl_Hz(i,j,k)
3625!^
3626 ad_hz(i,j,k)=ad_hz(i,j,k)+ad_wrk(i,j)
3627 ad_wrk(i,j)=0.0_r8
3628 END DO
3629 END DO
3630 END DO
3631 DO j=jstrv-1,jend
3632 DO i=istru-1,iend
3633!^ tl_wrk(i,j)=0.0_r8
3634!^
3635 ad_wrk(i,j)=0.0_r8
3636 END DO
3637 END DO
3638# ifdef DIAGNOSTICS_UV
3639!! DO j=JstrV,Jend
3640!! DO i=Istr,Iend
3641!! DiaRVfrc(i,j,3,M2bstr)=0.0_r8
3642!! DiaRVfrc(i,j,3,M2sstr)=0.0_r8
3643!! END DO
3644!! END DO
3645!! DO j=Jstr,Jend
3646!! DO i=IstrU,Iend
3647!! DiaRUfrc(i,j,3,M2bstr)=0.0_r8
3648!! DiaRUfrc(i,j,3,M2sstr)=0.0_r8
3649!! END DO
3650!! END DO
3651!! DO k=1,N(ng)
3652!! DO j=Jstr,Jend
3653!! DO i=Istr,Iend
3654!! DiaRU(i,j,k,nrhs,M3vvis)=0.0_r8
3655!! DiaRV(i,j,k,nrhs,M3vvis)=0.0_r8
3656!! END DO
3657!! END DO
3658!! END DO
3659# endif
3660# endif
3661!
3662 RETURN
mod_clima
Definition mod_clima.F:2
mod_clima::clima
type(t_clima), dimension(:), allocatable clima
Definition mod_clima.F:153
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_scalars
Definition mod_scalars.F:2
mod_scalars::levbfrc
integer, dimension(:), allocatable levbfrc
Definition mod_scalars.F:587
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::lnudgem3clm
logical, dimension(:), allocatable lnudgem3clm
Definition mod_scalars.F:534
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::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::levsfrc
integer, dimension(:), allocatable levsfrc
Definition mod_scalars.F:586

References mod_clima::clima, mod_scalars::compositegrid, mod_param::domain, mod_scalars::ewperiodic, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_scalars::levbfrc, mod_scalars::levsfrc, mod_scalars::lnudgem3clm, and mod_scalars::nsperiodic.

Referenced by ad_rhs3d().

Here is the caller graph for this function: