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

Functions/Subroutines

subroutine, public tl_step2d (ng, tile)
 
subroutine tl_step2d_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, nnew, pmask, rmask, umask, vmask, pmask_wet, pmask_full, rmask_wet, rmask_full, umask_wet, umask_full, vmask_wet, vmask_full, rmask_wet_avg, fomn, h, tl_h, om_u, om_v, on_u, on_v, pm, pn, dndx, dmde, rdrag, rdrag2, pmon_r, pnom_r, pmon_p, pnom_p, om_r, on_r, om_p, on_p, visc2_p, visc2_r, visc4_p, visc4_r, tl_bed_thick, tl_rustr2d, tl_rvstr2d, tl_rulag2d, tl_rvlag2d, ubar_stokes, tl_ubar_stokes, vbar_stokes, tl_vbar_stokes, eq_tide, tl_eq_tide, sustr, tl_sustr, svstr, tl_svstr, pair, rhoa, tl_rhoa, rhos, tl_rhos, tl_du_avg1, tl_du_avg2, tl_dv_avg1, tl_dv_avg2, tl_zt_avg1, rufrc, tl_rufrc, rvfrc, tl_rvfrc, tl_rufrc_bak, tl_rvfrc_bak, tl_du_flux, tl_dv_flux, ubar, tl_ubar, vbar, tl_vbar, zeta, tl_zeta)
 
subroutine tl_step2d_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, knew, nstp, nnew, pmask, rmask, umask, vmask, pmask_wet, pmask_full, rmask_wet, rmask_full, umask_wet, umask_full, vmask_wet, vmask_full, rmask_wet_avg, fomn, h, tl_h, om_u, om_v, on_u, on_v, omn, pm, pn, dndx, dmde, pmon_r, pnom_r, pmon_p, pnom_p, om_r, on_r, om_p, on_p, visc2_p, visc2_r, tl_bed_thick, tl_rustr2d, tl_rvstr2d, tl_rulag2d, tl_rvlag2d, ubar_stokes, tl_ubar_stokes, vbar_stokes, tl_vbar_stokes, eq_tide, tl_eq_tide, sustr, tl_sustr, svstr, tl_svstr, bustr, tl_bustr, bvstr, tl_bvstr, pair, rhoa, tl_rhoa, rhos, tl_rhos, tl_du_avg1, tl_du_avg2, tl_dv_avg1, tl_dv_avg2, tl_zt_avg1, rufrc, tl_rufrc, rvfrc, tl_rvfrc, tl_rufrc_bak, tl_rvfrc_bak, tl_du_flux, tl_dv_flux, ubar, tl_ubar, vbar, tl_vbar, zeta, tl_zeta)
 
subroutine tl_step2d_tile (ng, tile, lbi, ubi, lbj, ubj, ubk, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, nnew, pmask, rmask, umask, vmask, pmask_wet, pmask_full, rmask_wet, rmask_full, umask_wet, umask_full, vmask_wet, vmask_full, rmask_wet_avg, fomn, h, tl_h, om_u, om_v, on_u, on_v, omn, pm, pn, dndx, dmde, pmon_r, pnom_r, pmon_p, pnom_p, om_r, on_r, om_p, on_p, visc2_p, visc2_r, visc4_p, visc4_r, tl_bed_thick, tl_rustr2d, tl_rvstr2d, tl_rulag2d, tl_rvlag2d, ubar_stokes, tl_ubar_stokes, vbar_stokes, tl_vbar_stokes, eq_tide, tl_eq_tide, tl_bustr, tl_bvstr, pair, rhoa, tl_rhoa, rhos, tl_rhos, tl_du_avg1, tl_du_avg2, tl_dv_avg1, tl_dv_avg2, zt_avg1, tl_zt_avg1, tl_rufrc, tl_rvfrc, tl_ru, tl_rv, rubar, tl_rubar, rvbar, tl_rvbar, rzeta, tl_rzeta, ubar, tl_ubar, vbar, tl_vbar, zeta, tl_zeta)
 

Function/Subroutine Documentation

◆ tl_step2d()

subroutine public tl_step2d_mod::tl_step2d ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 79 of file tl_step2d_FB.h.

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

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

Referenced by tl_main3d().

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

◆ tl_step2d_tile() [1/3]

subroutine tl_step2d_mod::tl_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) omn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(in) tl_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_eq_tide,
sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_sustr,
svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_svstr,
bustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_bustr,
bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rufrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rvfrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) tl_du_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) tl_dv_flux,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_zeta )
private

Definition at line 197 of file tl_step2d_FB_LF_AM3.h.

275!***********************************************************************
276!
277! Imported variable declarations.
278!
279 integer, intent(in ) :: ng, tile
280 integer, intent(in ) :: LBi, UBi, LBj, UBj
281 integer, intent(in ) :: IminS, ImaxS, JminS, JmaxS
282 integer, intent(in ) :: kstp, knew
283#ifdef SOLVE3D
284 integer, intent(in ) :: nstp, nnew
285#endif
286!
287#ifdef ASSUMED_SHAPE
288# ifdef MASKING
289 real(r8), intent(in ) :: pmask(LBi:,LBj:)
290 real(r8), intent(in ) :: rmask(LBi:,LBj:)
291 real(r8), intent(in ) :: umask(LBi:,LBj:)
292 real(r8), intent(in ) :: vmask(LBi:,LBj:)
293# endif
294# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
295 real(r8), intent(in ) :: fomn(LBi:,LBj:)
296# endif
297 real(r8), intent(in ) :: h(LBi:,LBj:)
298 real(r8), intent(in ) :: om_u(LBi:,LBj:)
299 real(r8), intent(in ) :: om_v(LBi:,LBj:)
300 real(r8), intent(in ) :: on_u(LBi:,LBj:)
301 real(r8), intent(in ) :: on_v(LBi:,LBj:)
302 real(r8), intent(in ) :: omn(LBi:,LBj:)
303 real(r8), intent(in ) :: pm(LBi:,LBj:)
304 real(r8), intent(in ) :: pn(LBi:,LBj:)
305# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
306 real(r8), intent(in ) :: dndx(LBi:,LBj:)
307 real(r8), intent(in ) :: dmde(LBi:,LBj:)
308# endif
309# if defined UV_VIS2 && !defined SOLVE3D
310 real(r8), intent(in ) :: pmon_r(LBi:,LBj:)
311 real(r8), intent(in ) :: pnom_r(LBi:,LBj:)
312 real(r8), intent(in ) :: pmon_p(LBi:,LBj:)
313 real(r8), intent(in ) :: pnom_p(LBi:,LBj:)
314 real(r8), intent(in ) :: om_r(LBi:,LBj:)
315 real(r8), intent(in ) :: on_r(LBi:,LBj:)
316 real(r8), intent(in ) :: om_p(LBi:,LBj:)
317 real(r8), intent(in ) :: on_p(LBi:,LBj:)
318 real(r8), intent(in ) :: visc2_p(LBi:,LBj:)
319 real(r8), intent(in ) :: visc2_r(LBi:,LBj:)
320# endif
321# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
322 real(r8), intent(in ) :: tl_bed_thick(LBi:,LBj:,:)
323# endif
324# ifdef WEC_MELLOR
325 real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:)
326 real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:)
327# endif
328# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
329 real(r8), intent(in ) :: eq_tide(LBi:,LBj:)
330 real(r8), intent(in ) :: tl_eq_tide(LBi:,LBj:)
331# endif
332 real(r8), intent(in ) :: rufrc(LBi:,LBj:)
333 real(r8), intent(in ) :: rvfrc(LBi:,LBj:)
334 real(r8), intent(in ) :: ubar(LBi:,LBj:,:)
335 real(r8), intent(in ) :: vbar(LBi:,LBj:,:)
336 real(r8), intent(in ) :: zeta(LBi:,LBj:,:)
337
338# ifndef SOLVE3D
339 real(r8), intent(in ) :: tl_sustr(LBi:,LBj:)
340 real(r8), intent(in ) :: tl_svstr(LBi:,LBj:)
341 real(r8), intent(in ) :: tl_bustr(LBi:,LBj:)
342 real(r8), intent(in ) :: tl_bvstr(LBi:,LBj:)
343# ifdef ATM_PRESS
344 real(r8), intent(in ) :: Pair(LBi:,LBj:)
345# endif
346# else
347# ifdef VAR_RHO_2D
348 real(r8), intent(in ) :: rhoA(LBi:,LBj:)
349 real(r8), intent(in ) :: rhoS(LBi:,LBj:)
350 real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:)
351 real(r8), intent(in ) :: tl_rhoS(LBi:,LBj:)
352# endif
353 real(r8), intent(inout) :: tl_DU_avg1(LBi:,LBj:)
354 real(r8), intent(inout) :: tl_DU_avg2(LBi:,LBj:)
355 real(r8), intent(inout) :: tl_DV_avg1(LBi:,LBj:)
356 real(r8), intent(inout) :: tl_DV_avg2(LBi:,LBj:)
357 real(r8), intent(inout) :: tl_Zt_avg1(LBi:,LBj:)
358 real(r8), intent(inout) :: tl_rufrc(LBi:,LBj:)
359 real(r8), intent(inout) :: tl_rvfrc(LBi:,LBj:)
360 real(r8), intent(inout) :: tl_rufrc_bak(LBi:,LBj:,:)
361 real(r8), intent(inout) :: tl_rvfrc_bak(LBi:,LBj:,:)
362# endif
363# ifdef WEC_MELLOR
364 real(r8), intent(inout) :: tl_rustr2d(LBi:,LBj:)
365 real(r8), intent(inout) :: tl_rvstr2d(LBi:,LBj:)
366 real(r8), intent(inout) :: tl_rulag2d(LBi:,LBj:)
367 real(r8), intent(inout) :: tl_rvlag2d(LBi:,LBj:)
368 real(r8), intent(inout) :: tl_ubar_stokes(LBi:,LBj:)
369 real(r8), intent(inout) :: tl_vbar_stokes(LBi:,LBj:)
370# endif
371# ifdef WET_DRY_NOT_YET
372 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
373 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
374 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
375 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
376
377 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
378 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
379 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
380 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
381# ifdef SOLVE3D
382 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
383# endif
384# endif
385# ifdef DIAGNOSTICS_UV
386!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
387!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
388!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
389!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
390# ifdef SOLVE3D
391!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
392!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
393!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
394!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
395# endif
396# endif
397 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
398 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
399 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
400 real(r8), intent(inout) :: tl_h(LBi:,LBj:)
401# if defined NESTING && !defined SOLVE3D
402 real(r8), intent(out ) :: tl_DU_flux(LBi:,LBj:)
403 real(r8), intent(out ) :: tl_DV_flux(LBi:,LBj:)
404# endif
405
406#else
407
408# ifdef MASKING
409 real(r8), intent(in ) :: pmask(LBi:UBi,LBj:UBj)
410 real(r8), intent(in ) :: rmask(LBi:UBi,LBj:UBj)
411 real(r8), intent(in ) :: umask(LBi:UBi,LBj:UBj)
412 real(r8), intent(in ) :: vmask(LBi:UBi,LBj:UBj)
413# endif
414# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
415 real(r8), intent(in ) :: fomn(LBi:UBi,LBj:UBj)
416# endif
417 real(r8), intent(in ) :: h(LBi:UBi,LBj:UBj)
418 real(r8), intent(in ) :: om_u(LBi:UBi,LBj:UBj)
419 real(r8), intent(in ) :: om_v(LBi:UBi,LBj:UBj)
420 real(r8), intent(in ) :: on_u(LBi:UBi,LBj:UBj)
421 real(r8), intent(in ) :: on_v(LBi:UBi,LBj:UBj)
422 real(r8), intent(in ) :: omn(LBi:UBi,LBj:UBj)
423 real(r8), intent(in ) :: pm(LBi:UBi,LBj:UBj)
424 real(r8), intent(in ) :: pn(LBi:UBi,LBj:UBj)
425# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
426 real(r8), intent(in ) :: dndx(LBi:UBi,LBj:UBj)
427 real(r8), intent(in ) :: dmde(LBi:UBi,LBj:UBj)
428# endif
429# if defined UV_VIS2 && !defined SOLVE3D
430 real(r8), intent(in ) :: pmon_r(LBi:UBi,LBj:UBj)
431 real(r8), intent(in ) :: pnom_r(LBi:UBi,LBj:UBj)
432 real(r8), intent(in ) :: pmon_p(LBi:UBi,LBj:UBj)
433 real(r8), intent(in ) :: pnom_p(LBi:UBi,LBj:UBj)
434 real(r8), intent(in ) :: om_r(LBi:UBi,LBj:UBj)
435 real(r8), intent(in ) :: on_r(LBi:UBi,LBj:UBj)
436 real(r8), intent(in ) :: om_p(LBi:UBi,LBj:UBj)
437 real(r8), intent(in ) :: on_p(LBi:UBi,LBj:UBj)
438 real(r8), intent(in ) :: visc2_p(LBi:UBi,LBj:UBj)
439 real(r8), intent(in ) :: visc2_r(LBi:UBi,LBj:UBj)
440# endif
441# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
442 real(r8), intent(in ) :: tl_bed_thick(LBi:UBi,LBj:UBj,3)
443# endif
444# ifdef WEC_MELLOR
445 real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj)
446 real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj)
447# endif
448# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
449 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
450 real(r8), intent(in ) :: tl_eq_tide(LBi:UBi,LBj:UBj)
451# endif
452 real(r8), intent(in ) :: rufrc(LBi:UBi,LBj:UBj)
453 real(r8), intent(in ) :: rvfrc(LBi:UBi,LBj:UBj)
454 real(r8), intent(in ) :: ubar(LBi:UBi,LBj:UBj,:)
455 real(r8), intent(in ) :: vbar(LBi:UBi,LBj:UBj,:)
456 real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:)
457 real(r8), intent(inout) :: tl_h(LBi:UBi,LBj:UBj)
458# ifndef SOLVE3D
459 real(r8), intent(in ) :: tl_sustr(LBi:UBi,LBj:UBj)
460 real(r8), intent(in ) :: tl_svstr(LBi:UBi,LBj:UBj)
461 real(r8), intent(in ) :: tl_bustr(LBi:UBi,LBj:UBj)
462 real(r8), intent(in ) :: tl_bvstr(LBi:UBi,LBj:UBj)
463# ifdef ATM_PRESS
464 real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj)
465# endif
466# else
467# ifdef VAR_RHO_2D
468 real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj)
469 real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj)
470 real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj)
471 real(r8), intent(in ) :: tl_rhoS(LBi:UBi,LBj:UBj)
472# endif
473 real(r8), intent(inout) :: tl_DU_avg1(LBi:UBi,LBj:UBj)
474 real(r8), intent(inout) :: tl_DU_avg2(LBi:UBi,LBj:UBj)
475 real(r8), intent(inout) :: tl_DV_avg1(LBi:UBi,LBj:UBj)
476 real(r8), intent(inout) :: tl_DV_avg2(LBi:UBi,LBj:UBj)
477 real(r8), intent(inout) :: tl_Zt_avg1(LBi:UBi,LBj:UBj)
478 real(r8), intent(inout) :: tl_rufrc(LBi:UBi,LBj:UBj)
479 real(r8), intent(inout) :: tl_rvfrc(LBi:UBi,LBj:UBj)
480 real(r8), intent(inout) :: tl_rufrc_bak(LBi:UBi,LBj:UBj,2)
481 real(r8), intent(inout) :: tl_rvfrc_bak(LBi:UBi,LBj:UBj,2)
482# endif
483# ifdef WEC_MELLOR
484 real(r8), intent(inout) :: tl_rustr2d(LBi:UBi,LBj:UBj)
485 real(r8), intent(inout) :: tl_rvstr2d(LBi:UBi,LBj:UBj)
486 real(r8), intent(inout) :: tl_rulag2d(LBi:UBi,LBj:UBj)
487 real(r8), intent(inout) :: tl_rvlag2d(LBi:UBi,LBj:UBj)
488 real(r8), intent(inout) :: tl_ubar_stokes(LBi:UBi,LBj:UBj)
489 real(r8), intent(inout) :: tl_vbar_stokes(LBi:UBi,LBj:UBj)
490# endif
491# ifdef WET_DRY_NOT_YET
492 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
493 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
494 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
495 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
496
497 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
498 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
499 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
500 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
501# ifdef SOLVE3D
502 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
503# endif
504# endif
505# ifdef DIAGNOSTICS_UV
506!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
507!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
508!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
509!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
510# ifdef SOLVE3D
511!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
512!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
513!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
514!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
515# endif
516# endif
517 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
518 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
519 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
520# if defined NESTING && !defined SOLVE3D
521 real(r8), intent(out ) :: tl_DU_flux(LBi:UBi,LBj:UBj)
522 real(r8), intent(out ) :: tl_DV_flux(LBi:UBi,LBj:UBj)
523# endif
524#endif
525!
526! Local variable declarations.
527!
528 integer :: i, is, j
529 integer :: krhs, kbak
530#ifdef DIAGNOSTICS_UV
531 integer :: idiag
532#endif
533!
534 real(r8) :: cff, cff1, cff2, cff3, cff4
535#ifdef WET_DRY_NOT_YET
536 real(r8) :: cff5, cff6, cff7
537#endif
538 real(r8) :: fac, fac1, fac2
539 real(r8) :: tl_cff, tl_cff1, tl_cff2, tl_cff3, tl_cff4
540#ifdef WET_DRY_NOT_YET
541 real(r8) :: tl_cff5, tl_cff6, tl_cff7
542#endif
543 real(r8) :: tl_fac, tl_fac1, tl_fac2
544!
545#if defined UV_C4ADVECTION && !defined SOLVE3D
546 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
547#endif
548 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
549 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
550#if defined UV_VIS2 && !defined SOLVE3D
551 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
552#endif
553 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
554 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
555 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
556#ifdef WEC_MELLOR
557 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
558 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
559#endif
560#if defined STEP2D_CORIOLIS || !defined SOLVE3D
561 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
562 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
563#endif
564#if !defined SOLVE3D
565 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
566 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
567#endif
568#if defined UV_C4ADVECTION && !defined SOLVE3D
569 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
570#endif
571 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar
572 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar
573 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta
574 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2
575#if defined VAR_RHO_2D && defined SOLVE3D
576 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA
577#endif
578 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
579 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
580#ifdef WET_DRY_NOT_YET
581 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
582#endif
583#ifdef DIAGNOSTICS_UV
584!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
585!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
586!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaU2rhs
587!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaV2rhs
588#endif
589!
590#if defined UV_C4ADVECTION && !defined SOLVE3D
591 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dgrad
592#endif
593 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dnew
594 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs
595#if defined UV_VIS2 && !defined SOLVE3D
596 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs_p
597#endif
598 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dstp
599 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUon
600 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVom
601#ifdef WEC_MELLOR
602 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUSon
603 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVSom
604#endif
605#if defined STEP2D_CORIOLIS || !defined SOLVE3D
606 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFx
607 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFe
608#endif
609#if !defined SOLVE3D
610 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFe
611 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFx
612#endif
613#if defined UV_C4ADVECTION && !defined SOLVE3D
614 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad
615#endif
616 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2
617#if defined VAR_RHO_2D && defined SOLVE3D
618 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA
619#endif
620 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta
621 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rubar
622 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rvbar
623 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_zwrk
624!
625 real(r8), allocatable :: tl_zeta_new(:,:)
626!
627! The following stability limits are obtained empirically using 3/4
628! degree Atlantic model configuration. In all these cases barotropic
629! mode time step is about 180...250 seconds, which is much less than
630! the inertial period. The maximum stability coefficients turned out
631! to be slightly different than predicted by linear theory, although
632! all theoretical tendencies agree with the practice. Note the nearly
633! 70% gain in stability compared with LF-TR for appropriate
634! coefficients (linear theory predicts beta=0.166, epsil=0.84).
635!
636!! real(r8), parameter :: gamma=0.0_r8, &
637!! & beta =0.0_r8, epsil=0.0_r8 !--> Cu=0.818
638!! real(r8), parameter :: gamma=1.0_r8/12.0_r8, &
639!! & beta =0.0_r8, epsil=0.0_r8 !--> Cu=0.878
640!! real(r8), parameter :: gamma=1./12., &
641!! beta =0.1_r8, epsil=0.6_r8 !--> Cu=1.050
642 real(r8), parameter :: gamma=0.0_r8, &
643 & beta =0.14_r8, epsil=0.74_r8 !==> Cu=1.341
644
645#include "set_bounds.h"
646!
647!-----------------------------------------------------------------------
648! Timestep vertically integrated (barotropic) equations.
649!-----------------------------------------------------------------------
650!
651! In the code below it is assumed that variables with time index "krhs"
652! are time-centered at step "n" in barotropic time during predictor
653! sub-step and "n+1/2" during corrector.
654!
655 IF (predictor_2d_step) THEN
656 krhs=kstp
657 ELSE
658 krhs=3
659 END IF
660 IF (first_2d_step) THEN
661 kbak=kstp ! "kbak" is used as "from"
662 ELSE ! time index for LF timestep
663 kbak=3-kstp
664 END IF
665
666#ifdef DEBUG
667!
668 IF (master) THEN
669 WRITE (20,10) iic(ng), iif(ng), knew.eq.3, &
670 & kbak, krhs, kstp, knew
671 10 FORMAT (' iic = ',i5.5,' iif = ',i3.3, ' predictor = ', l1, &
672 & ' kbak = ',i1,' krhs = ',i1,' kstp = ',i1,' knew = ',i1)
673 END IF
674#endif
675!
676!-----------------------------------------------------------------------
677! Preliminary steps.
678!-----------------------------------------------------------------------
679!
680! Compute total depth of the water column and vertically integrated
681! mass fluxes, which are used in computation of free-surface elevation
682! time tendency and advection terms for the barotropic momentum
683! equations.
684!
685#if defined DISTRIBUTE && !defined NESTING
686# define IR_RANGE IstrUm2-1,Iendp2
687# define JR_RANGE JstrVm2-1,Jendp2
688# define IU_RANGE IstrUm1-1,Iendp2
689# define JU_RANGE Jstrm1-1,Jendp2
690# define IV_RANGE Istrm1-1,Iendp2
691# define JV_RANGE JstrVm1-1,Jendp2
692#else
693# define IR_RANGE IstrUm2-1,Iendp2
694# define JR_RANGE JstrVm2-1,Jendp2
695# define IU_RANGE IstrUm2,Iendp2
696# define JU_RANGE JstrVm2-1,Jendp2
697# define IV_RANGE IstrUm2-1,Iendp2
698# define JV_RANGE JstrVm2,Jendp2
699#endif
700
701 DO j=jr_range
702 DO i=ir_range
703 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
704 tl_drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
705 END DO
706 END DO
707 DO j=ju_range
708 DO i=iu_range
709 cff=0.5_r8*on_u(i,j)
710 cff1=cff*(drhs(i,j)+drhs(i-1,j))
711 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i-1,j))
712 duon(i,j)=ubar(i,j,krhs)*cff1
713 tl_duon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
714 & ubar(i,j,krhs)*tl_cff1
715 END DO
716 END DO
717 DO j=jv_range
718 DO i=iv_range
719 cff=0.5_r8*om_v(i,j)
720 cff1=cff*(drhs(i,j)+drhs(i,j-1))
721 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i,j-1))
722 dvom(i,j)=vbar(i,j,krhs)*cff1
723 tl_dvom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
724 & vbar(i,j,krhs)*tl_cff1
725 END DO
726 END DO
727
728#undef IR_RANGE
729#undef IU_RANGE
730#undef IV_RANGE
731#undef JR_RANGE
732#undef JU_RANGE
733#undef JV_RANGE
734
735#if defined DISTRIBUTE && \
736 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
737!
738! In distributed-memory, the I- and J-ranges are different and a
739! special exchange is done here to avoid having three ghost points
740! for high-order numerical stencils. Notice that a private array is
741! passed below to the exchange routine. It also applies periodic
742! boundary conditions, if appropriate and no partitions in I- or
743! J-directions.
744!
745 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
746 CALL exchange_u2d_tile (ng, tile, &
747 & imins, imaxs, jmins, jmaxs, &
748 & duon)
749 CALL exchange_u2d_tile (ng, tile, &
750 & imins, imaxs, jmins, jmaxs, &
751 & tl_duon)
752 CALL exchange_v2d_tile (ng, tile, &
753 & imins, imaxs, jmins, jmaxs, &
754 & dvom)
755 CALL exchange_v2d_tile (ng, tile, &
756 & imins, imaxs, jmins, jmaxs, &
757 & tl_dvom)
758 END IF
759 CALL mp_exchange2d (ng, tile, itlm, 4, &
760 & imins, imaxs, jmins, jmaxs, &
761 & nghostpoints, &
762 & ewperiodic(ng), nsperiodic(ng), &
763 & duon, dvom, &
764 & tl_duon, tl_dvom)
765#endif
766!
767! Compute integral mass flux across open boundaries and adjust
768! for volume conservation. Compute BASIC STATE value.
769!
770 IF (any(volcons(:,ng))) THEN
771 CALL obc_flux_tile (ng, tile, &
772 & lbi, ubi, lbj, ubj, &
773 & imins, imaxs, jmins, jmaxs, &
774 & knew, &
775#ifdef MASKING
776 & umask, vmask, &
777#endif
778 & h, om_v, on_u, &
779 & ubar, vbar, zeta)
780!
781! Set vertically integrated mass fluxes DUon and DVom along the open
782! boundaries in such a way that the integral volume is conserved.
783!
784 CALL set_duv_bc_tile (ng, tile, &
785 & lbi, ubi, lbj, ubj, &
786 & imins, imaxs, jmins, jmaxs, &
787 & krhs, &
788#ifdef MASKING
789 & umask, vmask, &
790#endif
791 & om_v, on_u, &
792 & ubar, vbar, &
793 & drhs, duon, dvom)
794 CALL tl_set_duv_bc_tile (ng, tile, &
795 & lbi, ubi, lbj, ubj, &
796 & imins, imaxs, jmins, jmaxs, &
797 & krhs, &
798#ifdef MASKING
799 & umask, vmask, &
800#endif
801 & om_v, on_u, &
802 & ubar, vbar, &
803 & tl_ubar, tl_vbar, &
804 & drhs, duon, dvom, &
805 & tl_drhs, tl_duon, tl_dvom)
806 END IF
807
808#ifdef SOLVE3D
809!
810!-----------------------------------------------------------------------
811! Fields averaged over all barotropic time steps.
812!-----------------------------------------------------------------------
813!
814! Notice that the index ranges here are designed to include physical
815! boundaries only. Periodic ghost points and internal mpi computational
816! margins are NOT included.
817!
818! Reset all barotropic mode time-averaged arrays during the first
819! predictor step. At all subsequent time steps, accumulate averages
820! of the first kind using the DELAYED way. For example, "Zt_avg1" is
821! not summed immediately after the corrector step when computed but
822! during the subsequent predictor substep. It allows saving operations
823! because "DUon" and "DVom" are calculated anyway. The last time step
824! has a special code to add all three barotropic variables after the
825! last corrector substep.
826!
827 IF (predictor_2d_step) THEN ! PREDICTOR STEP
828 IF (first_2d_step) THEN
829 DO j=jstrr,jendr
830 DO i=istrr,iendr
831!^ Zt_avg1(i,j)=0.0_r8
832!^
833 tl_zt_avg1(i,j)=0.0_r8
834!^ DU_avg1(i,j)=0.0_r8
835!^
836 tl_du_avg1(i,j)=0.0_r8
837!^ DV_avg1(i,j)=0.0_r8
838!^
839 tl_dv_avg1(i,j)=0.0_r8
840!^ DU_avg2(i,j)=0.0_r8
841!^
842 tl_du_avg2(i,j)=0.0_r8
843!^ DV_avg2(i,j)=0.0_r8
844!^
845 tl_dv_avg2(i,j)=0.0_r8
846 END DO
847 END DO
848 ELSE
849 cff=weight(1,iif(ng)-1,ng)
850 DO j=jstrr,jendr
851 DO i=istrr,iendr
852!^ Zt_avg1(i,j)=Zt_avg1(i,j)+cff*zeta(i,j,krhs)
853!^
854 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+cff*tl_zeta(i,j,krhs)
855 IF (i.ge.istr) THEN
856!^ DU_avg1(i,j)=DU_avg1(i,j)+cff*DUon(i,j)
857!^
858 tl_du_avg1(i,j)=tl_du_avg1(i,j)+cff*tl_duon(i,j)
859 END IF
860 IF (j.ge.jstr) THEN
861!^ DV_avg1(i,j)=DV_avg1(i,j)+cff*DVom(i,j)
862!^
863 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+cff*tl_dvom(i,j)
864 END IF
865 END DO
866 END DO
867 END IF
868 ELSE ! CORRECTOR STEP
869 cff=weight(2,iif(ng),ng)
870 DO j=jstrr,jendr
871 DO i=istrr,iendr
872 IF (i.ge.istr) THEN
873!^ DU_avg2(i,j)=DU_avg2(i,j)+cff*DUon(i,j)
874!^
875 tl_du_avg2(i,j)=tl_du_avg2(i,j)+cff*tl_duon(i,j)
876 END IF
877 IF (j.ge.jstr) THEN
878!^ DV_avg2(i,j)=DV_avg2(i,j)+cff*DVom(i,j)
879!^
880 tl_dv_avg2(i,j)=tl_dv_avg2(i,j)+cff*tl_dvom(i,j)
881 END IF
882 END DO
883 END DO
884 END IF
885#endif
886!
887!-----------------------------------------------------------------------
888! Tangent linear of advance free-surface.
889!-----------------------------------------------------------------------
890!
891! Notice that the new local free-surface is allocated so it can be
892! passed as an argumment to "zetabc" to avoid memory issues.
893!
894 allocate ( tl_zeta_new(imins:imaxs,jmins:jmaxs) )
895 tl_zeta_new = 0.0_r8
896!
897! Get background "zeta_new" from BASIC state. Notice the I- and J-range
898! used to avoid calling nonlinear 'zetabc_local' routine.
899!
900 DO j=lbj,ubj
901 DO i=lbi,ubi
902 zeta_new(i,j)=zeta(i,j,knew)
903#ifdef MASKING
904 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
905# ifdef WET_DRY_NOT_YET
906!! zeta_new(i,j)=zeta_new(i,j)+ &
907!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
908# endif
909#endif
910 dnew(i,j)=h(i,j)+zeta_new(i,j)
911 dstp(i,j)=h(i,j)+zeta(i,j,kstp)
912 END DO
913 END DO
914!
915! Compute "zeta_new" at the new time step and interpolate backward for
916! the subsequent computation of barotropic pressure-gradient terms.
917! Notice that during the predictor of the first 2D step in 3D mode,
918! the pressure gradient terms are computed using just zeta(:,:,kstp),
919! i.e., like in the Forward Euler step, rather than the more accurate
920! predictor of generalized RK2. This is to keep it consistent with the
921! computation of pressure gradient in 3D mode, which uses precisely
922! the initial value of "zeta" rather than the value changed by the
923! first barotropic predictor step. Later in this code, just after
924! "rufrc, rvfrc" are finalized, a correction term based on the
925! difference zeta_new(:,:)-zeta(:,:,kstp) to "rubar, rvbar" to make
926! them consistent with generalized RK2 stepping for pressure gradient
927! terms.
928!
929 IF (predictor_2d_step) THEN
930 IF (first_2d_step) THEN ! Modified RK2 time step (with
931 cff=dtfast(ng) ! Forward-Backward feedback with
932#ifdef SOLVE3D
933 cff1=0.0_r8 !==> Forward Euler
934 cff2=1.0_r8
935#else
936 cff1=0.333333333333_r8 ! optimally chosen beta=1/3 and
937 cff2=0.666666666667_r8 ! epsilon=2/3, see below) is used
938#endif
939 cff3=0.0_r8 ! here for the start up.
940 ELSE
941 cff=2.0_r8*dtfast(ng) ! In the code below "zwrk" is
942 cff1=beta ! time-centered at time step "n"
943 cff2=1.0_r8-2.0_r8*beta ! in the case of LF (for all but
944 cff3=beta ! the first time step)
945 END IF
946!
947 DO j=jstrv-1,jend
948 DO i=istru-1,iend
949 fac=cff*pm(i,j)*pn(i,j)
950!^ zeta_new(i,j)=zeta(i,j,kbak)+ &
951!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
952!^ & DVom(i,j)-DVom(i,j+1))
953!^
954 tl_zeta_new(i,j)=tl_zeta(i,j,kbak)+ &
955 & fac*(tl_duon(i,j)-tl_duon(i+1,j)+ &
956 & tl_dvom(i,j)-tl_dvom(i,j+1))
957#ifdef MASKING
958!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
959!^
960 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
961# ifdef WET_DRY_NOT_YET
962!! zeta_new(i,j)=zeta_new(i,j)+ &
963!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
964# endif
965#endif
966!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
967!^
968 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
969
970 zwrk(i,j)=cff1*zeta_new(i,j)+ &
971 & cff2*zeta(i,j,kstp)+ &
972 & cff3*zeta(i,j,kbak)
973 tl_zwrk(i,j)=cff1*tl_zeta_new(i,j)+ &
974 & cff2*tl_zeta(i,j,kstp)+ &
975 & cff3*tl_zeta(i,j,kbak)
976#if defined VAR_RHO_2D && defined SOLVE3D
977 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
978 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
979 & tl_rhos(i,j)*zwrk(i,j)
980 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
981 tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
982 & rzeta(i,j)*tl_zwrk(i,j)
983 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
984 tl_rzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
985 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
986#else
987 rzeta(i,j)=zwrk(i,j)
988 tl_rzeta(i,j)=tl_zwrk(i,j)
989 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
990 tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
991#endif
992 END DO
993 END DO
994 ELSE !--> CORRECTOR STEP
995 IF (first_2d_step) THEN
996 cff =0.333333333333_r8 ! Modified RK2 weighting:
997 cff1=0.333333333333_r8 ! here "zwrk" is time-
998 cff2=0.333333333333_r8 ! centered at "n+1/2".
999 cff3=0.0_r8
1000 ELSE
1001 cff =1.0_r8-epsil ! zwrk is always time-
1002 cff1=(0.5_r8-gamma)*epsil ! centered at n+1/2
1003 cff2=(0.5_r8+2.0_r8*gamma)*epsil ! during corrector sub-
1004 cff3=-gamma *epsil ! step.
1005 END IF
1006!
1007 DO j=jstrv-1,jend
1008 DO i=istru-1,iend
1009 fac=dtfast(ng)*pm(i,j)*pn(i,j)
1010!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1011!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
1012!^ & DVom(i,j)-DVom(i,j+1))
1013!^
1014 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1015 & fac*(tl_duon(i,j)-tl_duon(i+1,j)+ &
1016 & tl_dvom(i,j)-tl_dvom(i,j+1))
1017#ifdef MASKING
1018!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1019!^
1020 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1021# ifdef WET_DRY_NOT_YET
1022!! zeta_new(i,j)=zeta_new(i,j)+ &
1023!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
1024# endif
1025#endif
1026!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
1027!^
1028 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
1029
1030 zwrk(i,j)=cff *zeta(i,j,krhs)+ &
1031 & cff1*zeta_new(i,j)+ &
1032 & cff2*zeta(i,j,kstp)+ &
1033 & cff3*zeta(i,j,kbak)
1034 tl_zwrk(i,j)=cff *tl_zeta(i,j,krhs)+ &
1035 & cff1*tl_zeta_new(i,j)+ &
1036 & cff2*tl_zeta(i,j,kstp)+ &
1037 & cff3*tl_zeta(i,j,kbak)
1038#if defined VAR_RHO_2D && defined SOLVE3D
1039 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
1040 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
1041 & tl_rhos(i,j)*zwrk(i,j)
1042 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
1043 tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
1044 & rzeta(i,j)*tl_zwrk(i,j)
1045 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1046 tl_rzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1047 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
1048#else
1049 rzeta(i,j)=zwrk(i,j)
1050 tl_rzeta(i,j)=tl_zwrk(i,j)
1051 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1052 tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
1053#endif
1054 END DO
1055 END DO
1056 END IF
1057!
1058! Apply mass point sources (volume vertical influx), if any.
1059!
1060! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
1061!
1062 IF (lwsrc(ng)) THEN
1063 DO is=1,nsrc(ng)
1064 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
1065 i=sources(ng)%Isrc(is)
1066 j=sources(ng)%Jsrc(is)
1067 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1068 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1069!^ zeta_new(i,j)=zeta_new(i,j)+ &
1070!^ & SOURCES(ng)%Qbar(is)* &
1071!^ & pm(i,j)*pn(i,j)*dtfast(ng)
1072!^
1073! tl_zeta_new(i,j)=tl_zeta_new(i,j)+0.0_r8
1074 END IF
1075 END IF
1076 END DO
1077 END IF
1078!
1079! Apply boundary conditions to newly computed free-surface "zeta_new"
1080! and load into global state array. Notice that "zeta_new" is always
1081! centered at time step "m+1", while zeta(:,:,knew) should be centered
1082! either at "m+1/2" after predictor step and at "m+1" after corrector.
1083! Chosing it to be this way makes it possible avoid storing RHS for
1084! zeta, ubar, and vbar between predictor and corrector sub-steps.
1085!
1086! Here, we use the local "zetabc" since the private array "zeta_new"
1087! is passed as an argument to allow computing the lateral boundary
1088! conditions on the range IstrU-1:Iend and JstrV-1:Jend, so parallel
1089! tile exchanges are avoided.
1090!
1091!^ CALL zetabc_local (ng, tile, &
1092!^ & LBi, UBi, LBj, UBj, &
1093!^ & IminS, ImaxS, JminS, JmaxS, &
1094!^ & kstp, &
1095!^ & zeta, &
1096!^ & zeta_new)
1097!^
1098 CALL tl_zetabc_local (ng, tile, &
1099 & lbi, ubi, lbj, ubj, &
1100 & imins, imaxs, jmins, jmaxs, &
1101 & kstp, &
1102 & zeta, tl_zeta, &
1103 & zeta_new, tl_zeta_new)
1104!
1105 IF (predictor_2d_step) THEN
1106 IF (first_2d_step) THEN
1107 cff1=0.5_r8
1108 cff2=0.5_r8
1109 cff3=0.0_r8
1110 ELSE
1111 cff1=0.5_r8-gamma
1112 cff2=0.5_r8+2.0_r8*gamma
1113 cff3=-gamma
1114 END IF
1115 DO j=jstrr,jendr
1116 DO i=istrr,iendr
1117!^ zeta(i,j,knew)=cff1*zeta_new(i,j)+ &
1118!^ & cff2*zeta(i,j,kstp)+ &
1119!^ & cff3*zeta(i,j,kbak)
1120!^
1121 tl_zeta(i,j,knew)=cff1*tl_zeta_new(i,j)+ &
1122 & cff2*tl_zeta(i,j,kstp)+ &
1123 & cff3*tl_zeta(i,j,kbak)
1124 END DO
1125 END DO
1126 ELSE
1127 DO j=jstrr,jendr
1128 DO i=istrr,iendr
1129!^ zeta(i,j,knew)=zeta_new(i,j)
1130!^
1131 tl_zeta(i,j,knew)=tl_zeta_new(i,j)
1132 END DO
1133 END DO
1134 END IF
1135!
1136!=======================================================================
1137! Compute right-hand-side for the 2D momentum equations.
1138!=======================================================================
1139#ifdef SOLVE3D
1140!
1141! Notice that we are suppressing the computation of momentum advection,
1142! Coriolis, and lateral viscosity terms in 3D Applications because
1143! these terms are already included in the baroclinic-to-barotropic
1144! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely
1145! omitting them, but it is a choice between recomputing them at every
1146! barotropic step or keeping them "frozen" during the fast-time
1147! stepping.
1148# ifdef STEP2D_CORIOLIS
1149! However, in some coarse grid applications with larger baroclinic
1150! timestep (say, DT around 20 minutes or larger), adding the Coriolis
1151! term in the barotropic equations is useful since f*DT is no longer
1152! small.
1153# endif
1154#endif
1155!
1156!-----------------------------------------------------------------------
1157! Compute pressure-gradient terms.
1158!-----------------------------------------------------------------------
1159!
1160! Notice that "rubar" and "rvbar" are computed within the same to allow
1161! shared references to array elements (i,j), which increases the
1162! computational density by almost a factor of 1.5 resulting in overall
1163! more efficient code.
1164!
1165 cff1=0.5*g
1166 cff2=0.333333333333_r8
1167#if !defined SOLVE3D && defined ATM_PRESS
1168 fac=0.5_r8*100.0_r8/rho0
1169#endif
1170 DO j=jstr,jend
1171 DO i=istr,iend
1172 IF (i.ge.istru) THEN
1173!^ rubar(i,j)=cff1*on_u(i,j)* &
1174!^ & ((h(i-1,j)+ &
1175!^ & h(i ,j))* &
1176!^ & (rzeta(i-1,j)- &
1177!^ & rzeta(i ,j))+ &
1178#if defined VAR_RHO_2D && defined SOLVE3D
1179!^ & (h(i-1,j)- &
1180!^ & h(i ,j))* &
1181!^ & (rzetaSA(i-1,j)+ &
1182!^ & rzetaSA(i ,j)+ &
1183!^ & cff2*(rhoA(i-1,j)- &
1184!^ & rhoA(i ,j))* &
1185!^ & (zwrk(i-1,j)- &
1186!^ & zwrk(i ,j)))+ &
1187#endif
1188!^ & (rzeta2(i-1,j)- &
1189!^ & rzeta2(i ,j)))
1190!^
1191 tl_rubar(i,j)=cff1*on_u(i,j)* &
1192 & ((tl_h(i-1,j)+ &
1193 & tl_h(i ,j))* &
1194 & (rzeta(i-1,j)- &
1195 & rzeta(i ,j))+ &
1196 & (h(i-1,j)+ &
1197 & h(i ,j))* &
1198 & (tl_rzeta(i-1,j)- &
1199 & tl_rzeta(i ,j))+ &
1200#if defined VAR_RHO_2D && defined SOLVE3D
1201 & (tl_h(i-1,j)- &
1202 & tl_h(i ,j))* &
1203 & (rzetasa(i-1,j)+ &
1204 & rzetasa(i ,j)+ &
1205 & cff2*(rhoa(i-1,j)- &
1206 & rhoa(i ,j))* &
1207 & (zwrk(i-1,j)- &
1208 & zwrk(i ,j)))+ &
1209 & (h(i-1,j)- &
1210 & h(i ,j))* &
1211 & (tl_rzetasa(i-1,j)+ &
1212 & tl_rzetasa(i ,j)+ &
1213 & cff2*((tl_rhoa(i-1,j)- &
1214 & tl_rhoa(i ,j))* &
1215 & (zwrk(i-1,j)- &
1216 & zwrk(i ,j))+ &
1217 & (rhoa(i-1,j)- &
1218 & rhoa(i ,j))* &
1219 & (tl_zwrk(i-1,j)- &
1220 & tl_zwrk(i ,j))))+ &
1221#endif
1222 & (tl_rzeta2(i-1,j)- &
1223 & tl_rzeta2(i ,j)))
1224#if defined ATM_PRESS && !defined SOLVE3D
1225!^ rubar(i,j)=rubar(i,j)- &
1226!^ & fac*on_u(i,j)* &
1227!^ & (h(i-1,j)+h(i,j)+ &
1228!^ & rzeta(i-1,j)+rzeta(i,j))* &
1229!^ & (Pair(i,j)-Pair(i-1,j))
1230!^
1231 tl_rubar(i,j)=tl_rubar(i,j)- &
1232 & fac*on_u(i,j)* &
1233 & (tl_h(i-1,j)+tl_h(i,j)+ &
1234 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1235 & (pair(i,j)-pair(i-1,j))
1236#endif
1237#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1238!^ rubar(i,j)=rubar(i,j)- &
1239!^ & cff1*on_u(i,j)* &
1240!^ & (h(i-1,j)+h(i,j)+ &
1241!^ & rzeta(i-1,j)+rzeta(i,j))* &
1242!^ & (eq_tide(i,j)-eq_tide(i-1,j))
1243!^
1244 tl_rubar(i,j)=tl_rubar(i,j)- &
1245 & cff1*on_u(i,j)* &
1246 & ((tl_h(i-1,j)+tl_h(i,j)+ &
1247 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1248 & (eq_tide(i,j)-eq_tide(i-1,j))+ &
1249 & (h(i-1,j)+h(i,j)+ &
1250 & rzeta(i-1,j)+rzeta(i,j))* &
1251 & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
1252#endif
1253#ifdef DIAGNOSTICS_UV
1254!! DiaU2rhs(i,j,M2pgrd)=rubar(i,j)
1255#endif
1256 END IF
1257!
1258 IF (j.ge.jstrv) THEN
1259!^ rvbar(i,j)=cff1*om_v(i,j)* &
1260!^ & ((h(i,j-1)+ &
1261!^ & h(i,j ))* &
1262!^ & (rzeta(i,j-1)- &
1263!^ & rzeta(i,j ))+ &
1264#if defined VAR_RHO_2D && defined SOLVE3D
1265!^ & (h(i,j-1)- &
1266!^ & h(i,j ))* &
1267!^ & (rzetaSA(i,j-1)+ &
1268!^ & rzetaSA(i,j )+ &
1269!^ & cff2*(rhoA(i,j-1)- &
1270!^ & rhoA(i,j ))* &
1271!^ & (zwrk(i,j-1)- &
1272!^ & zwrk(i,j )))+ &
1273#endif
1274!^ & (rzeta2(i,j-1)- &
1275!^ & rzeta2(i,j )))
1276!^
1277 tl_rvbar(i,j)=cff1*om_v(i,j)* &
1278 & ((tl_h(i,j-1)+ &
1279 & tl_h(i,j ))* &
1280 & (rzeta(i,j-1)- &
1281 & rzeta(i,j ))+ &
1282 & (h(i,j-1)+ &
1283 & h(i,j ))* &
1284 & (tl_rzeta(i,j-1)- &
1285 & tl_rzeta(i,j ))+ &
1286#if defined VAR_RHO_2D && defined SOLVE3D
1287 & (tl_h(i,j-1)- &
1288 & tl_h(i,j ))* &
1289 & (rzetasa(i,j-1)+ &
1290 & rzetasa(i,j )+ &
1291 & cff2*(rhoa(i,j-1)- &
1292 & rhoa(i,j ))* &
1293 & (zwrk(i,j-1)- &
1294 & zwrk(i,j )))+ &
1295 & (h(i,j-1)- &
1296 & h(i,j ))* &
1297 & (tl_rzetasa(i,j-1)+ &
1298 & tl_rzetasa(i,j )+ &
1299 & cff2*((tl_rhoa(i,j-1)- &
1300 & tl_rhoa(i,j ))* &
1301 & (zwrk(i,j-1)- &
1302 & zwrk(i,j ))+ &
1303 & (rhoa(i,j-1)- &
1304 & rhoa(i,j ))* &
1305 & (tl_zwrk(i,j-1)- &
1306 & tl_zwrk(i,j ))))+ &
1307#endif
1308 & (tl_rzeta2(i,j-1)- &
1309 & tl_rzeta2(i,j )))
1310#if defined ATM_PRESS && !defined SOLVE3D
1311!^ rvbar(i,j)=rvbar(i,j)- &
1312!^ & fac*om_v(i,j)* &
1313!^ & (h(i,j-1)+h(i,j)+ &
1314!^ & rzeta(i,j-1)+rzeta(i,j))* &
1315!^ & (Pair(i,j)-Pair(i,j-1))
1316!^
1317 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1318 & fac*om_v(i,j)* &
1319 & (tl_h(i,j-1)+tl_h(i,j)+ &
1320 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1321 & (pair(i,j)-pair(i,j-1))
1322#endif
1323#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1324!^ rvbar(i,j)=rvbar(i,j)- &
1325!^ & cff1*om_v(i,j)* &
1326!^ & (h(i,j-1)+h(i,j)+ &
1327!^ & rzeta(i,j-1)+rzeta(i,j))* &
1328!^ & (eq_tide(i,j)-eq_tide(i,j-1))
1329!^
1330 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1331 & cff1*om_v(i,j)* &
1332 & ((tl_h(i,j-1)+tl_h(i,j)+ &
1333 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1334 & (eq_tide(i,j)-eq_tide(i,j-1))+ &
1335 & (h(i,j-1)+h(i,j)+ &
1336 & rzeta(i,j-1)+rzeta(i,j))* &
1337 & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
1338#endif
1339#ifdef DIAGNOSTICS_UV
1340!! DiaV2rhs(i,j,M2pgrd)=rvbar(i,j)
1341#endif
1342 END IF
1343 END DO
1344 END DO
1345
1346#if defined UV_ADV && !defined SOLVE3D
1347!
1348!-----------------------------------------------------------------------
1349! Add in horizontal advection of momentum.
1350!-----------------------------------------------------------------------
1351
1352# ifdef UV_C2ADVECTION
1353!
1354! Second-order, centered differences advection fluxes.
1355!
1356 DO j=jstr,jend
1357 DO i=istru-1,iend
1358!^ UFx(i,j)=0.25_r8* &
1359!^ & (DUon(i,j)+DUon(i+1,j))* &
1360!^ & (ubar(i ,j,krhs)+ &
1361# ifdef WEC_MELLOR
1362!^ & ubar_stokes(i ,j)+ &
1363!^ & ubar_stokes(i+1,j)+ &
1364# endif
1365!^ & ubar(i+1,j,krhs))
1366!^
1367 tl_ufx(i,j)=0.25_r8* &
1368 & ((tl_duon(i,j)+tl_duon(i+1,j))* &
1369 & (ubar(i ,j,krhs)+ &
1370# ifdef WEC_MELLOR
1371 & ubar_stokes(i ,j)+ &
1372 & ubar_stokes(i+1,j)+ &
1373# endif
1374 & ubar(i+1,j,krhs))+ &
1375 & (duon(i,j)+duon(i+1,j))* &
1376 & (tl_ubar(i ,j,krhs)+ &
1377# ifdef WEC_MELLOR
1378 & tl_ubar_stokes(i ,j)+ &
1379 & tl_ubar_stokes(i+1,j)+ &
1380# endif
1381 & tl_ubar(i+1,j,krhs)))
1382 END DO
1383 END DO
1384!
1385 DO j=jstr,jend+1
1386 DO i=istru,iend
1387!^ UFe(i,j)=0.25_r8* &
1388!^ & (DVom(i,j)+DVom(i-1,j))* &
1389!^ & (ubar(i,j ,krhs)+ &
1390# ifdef WEC_MELLOR
1391!^ & ubar_stokes(i,j )+ &
1392!^ & ubar_stokes(i,j-1)+ &
1393# endif
1394!^ & ubar(i,j-1,krhs))
1395!^
1396 tl_ufe(i,j)=0.25_r8* &
1397 & ((tl_dvom(i,j)+tl_dvom(i-1,j))* &
1398 & (ubar(i,j ,krhs)+ &
1399# ifdef WEC_MELLOR
1400 & ubar_stokes(i,j )+ &
1401 & ubar_stokes(i,j-1)+ &
1402# endif
1403 & ubar(i,j-1,krhs))+ &
1404 & (dvom(i,j)+dvom(i-1,j))* &
1405 & (tl_ubar(i,j ,krhs)+ &
1406# ifdef WEC_MELLOR
1407 & tl_ubar_stokes(i,j )+ &
1408 & tl_ubar_stokes(i,j-1)+ &
1409# endif
1410 & tl_ubar(i,j-1,krhs)))
1411 END DO
1412 END DO
1413!
1414 DO j=jstrv,jend
1415 DO i=istr,iend+1
1416!^ VFx(i,j)=0.25_r8* &
1417!^ & (DUon(i,j)+DUon(i,j-1))* &
1418!^ & (vbar(i ,j,krhs)+ &
1419# ifdef WEC_MELLOR
1420!^ & vbar_stokes(i ,j)+ &
1421!^ & vbar_stokes(i-1,j)+ &
1422# endif
1423!^ & vbar(i-1,j,krhs))
1424!^
1425 tl_vfx(i,j)=0.25_r8* &
1426 & ((tl_duon(i,j)+tl_duon(i,j-1))* &
1427 & (vbar(i ,j,krhs)+ &
1428# ifdef WEC_MELLOR
1429 & vbar_stokes(i ,j)+ &
1430 & vbar_stokes(i-1,j)+ &
1431# endif
1432 & vbar(i-1,j,krhs))+ &
1433 & (duon(i,j)+duon(i,j-1))* &
1434 & (tl_vbar(i ,j,krhs)+ &
1435# ifdef WEC_MELLOR
1436 & tl_vbar_stokes(i ,j)+ &
1437 & tl_vbar_stokes(i-1,j)+ &
1438# endif
1439 & tl_vbar(i-1,j,krhs)))
1440 END DO
1441 END DO
1442!
1443 DO j=jstrv-1,jend
1444 DO i=istr,iend
1445!^ VFe(i,j)=0.25_r8* &
1446!^ & (DVom(i,j)+DVom(i,j+1))* &
1447!^ & (vbar(i,j ,krhs)+ &
1448# ifdef WEC_MELLOR
1449!^ & vbar_stokes(i,j )+ &
1450!^ & vbar_stokes(i,j+1)+ &
1451# endif
1452!^ & vbar(i,j+1,krhs))
1453!^
1454 tl_vfe(i,j)=0.25_r8* &
1455 & ((tl_dvom(i,j)+tl_dvom(i,j+1))* &
1456 & (vbar(i,j ,krhs)+ &
1457# ifdef WEC_MELLOR
1458 & vbar_stokes(i,j )+ &
1459 & vbar_stokes(i,j+1)+ &
1460# endif
1461 & vbar(i,j+1,krhs))+ &
1462 & (dvom(i,j)+dvom(i,j+1))* &
1463 & (tl_vbar(i,j ,krhs)+ &
1464# ifdef WEC_MELLOR
1465 & tl_vbar_stokes(i,j )+ &
1466 & tl_vbar_stokes(i,j+1)+ &
1467# endif
1468 & tl_vbar(i,j+1,krhs)))
1469 END DO
1470 END DO
1471
1472# elif defined UV_C4ADVECTION
1473!
1474! Fourth-order, centered differences u-momentum advection fluxes.
1475!
1476 DO j=jstr,jend
1477 DO i=istrum1,iendp1
1478 grad(i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1479# ifdef WEC_MELLOR
1480 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
1481 & ubar_stokes(i+1,j)+ &
1482# endif
1483 & ubar(i+1,j,krhs)
1484 tl_grad(i,j)=tl_ubar(i-1,j,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1485# ifdef WEC_MELLOR
1486 & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
1487 & tl_ubar_stokes(i+1,j)+ &
1488# endif
1489 & tl_ubar(i+1,j,krhs)
1490 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
1491 tl_dgrad(i,j)=tl_duon(i-1,j)-2.0_r8*tl_duon(i,j)+ &
1492 & tl_duon(i+1,j)
1493 END DO
1494 END DO
1495 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1496 IF (domain(ng)%Western_Edge(tile)) THEN
1497 DO j=jstr,jend
1498 grad(istr,j)=grad(istr+1,j)
1499 tl_grad(istr,j)=tl_grad(istr+1,j)
1500 dgrad(istr,j)=dgrad(istr+1,j)
1501 tl_dgrad(istr,j)=tl_dgrad(istr+1,j)
1502 END DO
1503 END IF
1504 END IF
1505 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1506 IF (domain(ng)%Eastern_Edge(tile)) THEN
1507 DO j=jstr,jend
1508 grad(iend+1,j)=grad(iend,j)
1509 tl_grad(iend+1,j)=tl_grad(iend,j)
1510 dgrad(iend+1,j)=dgrad(iend,j)
1511 tl_dgrad(iend+1,j)=tl_dgrad(iend,j)
1512 END DO
1513 END IF
1514 END IF
1515! d/dx(Duu/n)
1516 cff=1.0_r8/6.0_r8
1517 DO j=jstr,jend
1518 DO i=istru-1,iend
1519!^ UFx(i,j)=0.25_r8*(ubar(i ,j,krhs)+ &
1520# ifdef WEC_MELLOR
1521!^ & ubar_stokes(i ,j)+ &
1522!^ & ubar_stokes(i+1,j)+ &
1523# endif
1524!^ & ubar(i+1,j,krhs)- &
1525!^ & cff*(grad (i,j)+grad (i+1,j)))* &
1526!^ & (DUon(i,j)+DUon(i+1,j)- &
1527!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j)))
1528!^
1529 tl_ufx(i,j)=0.25_r8* &
1530 & ((tl_ubar(i ,j,krhs)+ &
1531# ifdef WEC_MELLOR
1532 & tl_ubar_stokes(i ,j)+ &
1533 & tl_ubar_stokes(i+1,j)+ &
1534# endif
1535 & tl_ubar(i+1,j,krhs)- &
1536 & cff*(tl_grad(i,j)+tl_grad(i+1,j)))* &
1537 & (duon(i,j)+duon(i+1,j)- &
1538 & cff*(dgrad(i,j)+dgrad(i+1,j)))+ &
1539 & (ubar(i ,j,krhs)+ &
1540# ifdef WEC_MELLOR
1541 & ubar_stokes(i ,j)+ &
1542 & ubar_stokes(i+1,j)+ &
1543# endif
1544 & ubar(i+1,j,krhs)- &
1545 & cff*(grad(i,j)+grad(i+1,j)))* &
1546 & (tl_duon(i,j)+tl_duon(i+1,j)- &
1547 & cff*(tl_dgrad(i,j)+tl_dgrad(i+1,j))))
1548!
1549 DO j=jstrm1,jendp1
1550 DO i=istru,iend
1551 grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1552# ifdef WEC_MELLOR
1553 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
1554 & ubar_stokes(i,j+1)+ &
1555# endif
1556 & ubar(i,j+1,krhs)
1557 tl_grad(i,j)=tl_ubar(i,j-1,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1558# ifdef WEC_MELLOR
1559 & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
1560 & tl_ubar_stokes(i,j+1)+ &
1561# endif
1562 & tl_ubar(i,j+1,krhs)
1563 END DO
1564 END DO
1565!
1566 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1567 IF (domain(ng)%Southern_Edge(tile)) THEN
1568 DO i=istru,iend
1569 grad(i,jstr-1)=grad(i,jstr)
1570 tl_grad(i,jstr-1)=tl_grad(i,jstr)
1571 END DO
1572 END IF
1573 END IF
1574 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1575 IF (domain(ng)%Northern_Edge(tile)) THEN
1576 DO i=istru,iend
1577 grad(i,jend+1)=grad(i,jend)
1578 tl_grad(i,jend+1)=tl_grad(i,jend)
1579 END DO
1580 END IF
1581 END IF
1582 DO j=jstr,jend+1
1583 DO i=istru-1,iend
1584 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
1585 tl_dgrad(i,j)=tl_dvom(i-1,j)-2.0_r8*tl_dvom(i,j)+ &
1586 & tl_dvom(i+1,j)
1587 END DO
1588 END DO
1589! d/dy(Duv/m)
1590 cff=1.0_r8/6.0_r8
1591 DO j=jstr,jend+1
1592 DO i=istru,iend
1593!^ UFe(i,j)=0.25_r8*(ubar(i,j ,krhs)+ &
1594# ifdef WEC_MELLOR
1595!^ & ubar_stokes(i,j )+ &
1596!^ & ubar_stokes(i,j-1)+ &
1597# endif
1598!^ & ubar(i,j-1,krhs)- &
1599!^ & cff*(grad (i,j)+grad (i,j-1)))* &
1600!^ & (DVom(i,j)+DVom(i-1,j)- &
1601!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))
1602!^
1603 tl_ufe(i,j)=0.25_r8* &
1604 & ((tl_ubar(i,j ,krhs)+ &
1605# ifdef WEC_MELLOR
1606 & tl_ubar_stokes(i,j )+ &
1607 & tl_ubar_stokes(i,j-1)+ &
1608# endif
1609 & tl_ubar(i,j-1,krhs)- &
1610 & cff*(tl_grad(i,j)+tl_grad(i,j-1)))* &
1611 & (dvom(i,j)+dvom(i-1,j)- &
1612 & cff*(dgrad(i,j)+dgrad(i-1,j)))+ &
1613 & (ubar(i,j ,krhs)+ &
1614# ifdef WEC_MELLOR
1615 & ubar_stokes(i,j )+ &
1616 & ubar_stokes(i,j-1)+ &
1617# endif
1618 & ubar(i,j-1,krhs)- &
1619 & cff*(grad(i,j)+grad(i,j-1)))* &
1620 & (tl_dvom(i,j)+tl_dvom(i-1,j)- &
1621 & cff*(tl_dgrad(i,j)+tl_dgrad(i-1,j))))
1622 END DO
1623 END DO
1624!
1625! Fourth-order, centered differences v-momentum advection fluxes.
1626!
1627 DO j=jstrv,jend
1628 DO i=istrm1,iendp1
1629 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1630# ifdef WEC_MELLOR
1631 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
1632 & vbar_stokes(i+1,j)+ &
1633# endif
1634 & vbar(i+1,j,krhs)
1635 tl_grad(i,j)=tl_vbar(i-1,j,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1636# ifdef WEC_MELLOR
1637 & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
1638 & tl_vbar_stokes(i+1,j)+ &
1639# endif
1640 & tl_vbar(i+1,j,krhs)
1641 END DO
1642 END DO
1643!
1644 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1645 IF (domain(ng)%Western_Edge(tile)) THEN
1646 DO j=jstrv,jend
1647 grad(istr-1,j)=grad(istr,j)
1648 tl_grad(istr-1,j)=tl_grad(istr,j)
1649 END DO
1650 END IF
1651 END IF
1652 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1653 IF (domain(ng)%Eastern_Edge(tile)) THEN
1654 DO j=jstrv,jend
1655 grad(iend+1,j)=grad(iend,j)
1656 tl_grad(iend+1,j)=tl_grad(iend,j)
1657 END DO
1658 END IF
1659 END IF
1660 DO j=jstrv-1,jend
1661 DO i=istr,iend+1
1662 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
1663 tl_dgrad(i,j)=tl_duon(i,j-1)-2.0_r8*tl_duon(i,j)+ &
1664 & tl_duon(i,j+1)
1665 END DO
1666 END DO
1667! d/dx(Duv/n)
1668 cff=1.0_r8/6.0_r8
1669 DO j=jstrv,jend
1670 DO i=istr,iend+1
1671!^ VFx(i,j)=0.25_r8*(vbar(i ,j,krhs)+ &
1672# ifdef WEC_MELLOR
1673!^ & vbar_stokes(i ,j)+ &
1674!^ & vbar_stokes(i-1,j)+ &
1675# endif
1676!^ & vbar(i-1,j,krhs)- &
1677!^ & cff*(grad (i,j)+grad (i-1,j)))* &
1678!^ & (DUon(i,j)+DUon(i,j-1)- &
1679!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))
1680!^
1681 tl_vfx(i,j)=0.25_r8* &
1682 & ((tl_vbar(i ,j,krhs)+ &
1683# ifdef WEC_MELLOR
1684 & tl_vbar_stokes(i ,j)+ &
1685 & tl_vbar_stokes(i-1,j)+ &
1686# endif
1687 & tl_vbar(i-1,j,krhs)- &
1688 & cff*(tl_grad(i,j)+tl_grad(i-1,j)))* &
1689 & (duon(i,j)+duon(i,j-1)- &
1690 & cff*(dgrad(i,j)+dgrad(i,j-1)))+ &
1691 & (vbar(i ,j,krhs)+ &
1692# ifdef WEC_MELLOR
1693 & vbar_stokes(i ,j)+ &
1694 & vbar_stokes(i-1,j)+ &
1695# endif
1696 & vbar(i-1,j,krhs)- &
1697 & cff*(grad(i,j)+grad(i-1,j)))* &
1698 & (tl_duon(i,j)+tl_duon(i,j-1)- &
1699 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j-1))))
1700 END DO
1701 END DO
1702!
1703 DO j=jstrvm1,jendp1
1704 DO i=istr,iend
1705 grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1706# ifdef WEC_MELLOR
1707 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
1708 & vbar_stokes(i,j+1)+ &
1709# endif
1710 & vbar(i,j+1,krhs)
1711 tl_grad(i,j)=tl_vbar(i,j-1,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1712# ifdef WEC_MELLOR
1713 & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
1714 & tl_vbar_stokes(i,j+1)+ &
1715# endif
1716 & tl_vbar(i,j+1,krhs)
1717 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
1718 tl_dgrad(i,j)=tl_dvom(i,j-1)-2.0_r8*tl_dvom(i,j)+ &
1719 & tl_dvom(i,j+1)
1720 END DO
1721 END DO
1722 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1723 IF (domain(ng)%Southern_Edge(tile)) THEN
1724 DO i=istr,iend
1725 grad(i,jstr)=grad(i,jstr+1)
1726 tl_grad(i,jstr)=tl_grad(i,jstr+1)
1727 dgrad(i,jstr)=dgrad(i,jstr+1)
1728 tl_dgrad(i,jstr)=tl_dgrad(i,jstr+1)
1729 END DO
1730 END IF
1731 END IF
1732 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1733 IF (domain(ng)%Northern_Edge(tile)) THEN
1734 DO i=istr,iend
1735 grad(i,jend+1)=grad(i,jend)
1736 tl_grad(i,jend+1)=tl_grad(i,jend)
1737 dgrad(i,jend+1)=dgrad(i,jend)
1738 tl_dgrad(i,jend+1)=tl_dgrad(i,jend)
1739 END DO
1740 END IF
1741 END IF
1742! d/dy(Dvv/m)
1743 cff=1.0_r8/6.0_r8
1744 DO j=jstrv-1,jend
1745 DO i=istr,iend
1746!^ VFe(i,j)=0.25_r8*(vbar(i,j ,krhs)+ &
1747# ifdef WEC_MELLOR
1748!^ & vbar_stokes(i,j )+ &
1749!^ & vbar_stokes(i,j+1)+ &
1750# endif
1751!^ & vbar(i,j+1,krhs)- &
1752!^ & cff*(grad (i,j)+grad (i,j+1)))* &
1753!^ & (DVom(i,j)+DVom(i,j+1)- &
1754!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))
1755!^
1756 tl_vfe(i,j)=0.25_r8* &
1757 & ((tl_vbar(i,j ,krhs)+ &
1758# ifdef WEC_MELLOR
1759 & tl_vbar_stokes(i,j )+ &
1760 & tl_vbar_stokes(i,j+1)+ &
1761# endif
1762 & tl_vbar(i,j+1,krhs)- &
1763 & cff*(tl_grad(i,j)+tl_grad(i,j+1)))* &
1764 & (dvom(i,j)+dvom(i,j+1)- &
1765 & cff*(dgrad(i,j)+dgrad(i,j+1)))+ &
1766 & (vbar(i,j ,krhs)+ &
1767# ifdef WEC_MELLOR
1768 & vbar_stokes(i,j )+ &
1769 & vbar_stokes(i,j+1)+ &
1770# endif
1771 & vbar(i,j+1,krhs)- &
1772 & cff*(grad(i,j)+grad(i,j+1)))* &
1773 & (tl_dvom(i,j)+tl_dvom(i,j+1)- &
1774 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j+1))))
1775 END DO
1776 END DO
1777# endif
1778!
1779! Add advection to RHS terms.
1780!
1781 DO j=jstr,jend
1782 DO i=istr,iend
1783 IF (i.ge.istru) THEN
1784!^ cff1=UFx(i,j)-UFx(i-1,j)
1785!^
1786 tl_cff1=tl_ufx(i,j)-tl_ufx(i-1,j)
1787!^ cff2=UFe(i,j+1)-UFe(i,j)
1788!^
1789 tl_cff2=tl_ufe(i,j+1)-tl_ufe(i,j)
1790!^ fac=cff1+cff2
1791!^
1792 tl_fac=tl_cff1+tl_cff2
1793!^ rubar(i,j)=rubar(i,j)-fac
1794!^
1795 tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
1796# if defined DIAGNOSTICS_UV
1797!! DiaU2rhs(i,j,M2xadv)=-cff1
1798!! DiaU2rhs(i,j,M2yadv)=-cff2
1799!! DiaU2rhs(i,j,M2hadv)=-fac
1800# endif
1801 END IF
1802!
1803 IF (j.ge.jstrv) THEN
1804!^ cff1=VFx(i+1,j)-VFx(i,j)
1805!^
1806 tl_cff1=tl_vfx(i+1,j)-tl_vfx(i,j)
1807!^ cff2=VFe(i,j)-VFe(i,j-1)
1808!^
1809 tl_cff2=tl_vfe(i,j)-tl_vfe(i,j-1)
1810!^ fac=cff1+cff2
1811!^
1812 tl_fac=tl_cff1+tl_cff2
1813!^ rvbar(i,j)=rvbar(i,j)-fac
1814!^
1815 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
1816# if defined DIAGNOSTICS_UV
1817!! DiaV2rhs(i,j,M2xadv)=-cff1
1818!! DiaV2rhs(i,j,M2yadv)=-cff2
1819!! DiaV2rhs(i,j,M2hadv)=-fac
1820# endif
1821 END IF
1822 END DO
1823 END DO
1824#endif
1825
1826#if (defined UV_COR & !defined SOLVE3D) || defined STEP2D_CORIOLIS
1827!
1828!-----------------------------------------------------------------------
1829! Add in Coriolis term.
1830!-----------------------------------------------------------------------
1831!
1832 DO j=jstrv-1,jend
1833 DO i=istru-1,iend
1834 cff=0.5_r8*drhs(i,j)*fomn(i,j)
1835 tl_cff=0.5_r8*tl_drhs(i,j)*fomn(i,j)
1836!^ UFx(i,j)=cff*(vbar(i,j ,krhs)+ &
1837# ifdef WEC_MELLOR
1838!^ & vbar_stokes(i,j )+ &
1839!^ & vbar_stokes(i,j+1)+ &
1840# endif
1841!^ & vbar(i,j+1,krhs))
1842!^
1843 tl_ufx(i,j)=tl_cff*(vbar(i,j ,krhs)+ &
1844# ifdef WEC_MELLOR
1845 & vbar_stokes(i,j )+ &
1846 & vbar_stokes(i,j+1)+ &
1847# endif
1848 & vbar(i,j+1,krhs))+ &
1849 & cff*(tl_vbar(i,j ,krhs)+ &
1850# ifdef WEC_MELLOR
1851 & tl_vbar_stokes(i,j )+ &
1852 & tl_vbar_stokes(i,j+1)+ &
1853# endif
1854 & tl_vbar(i,j+1,krhs))
1855!^ VFe(i,j)=cff*(ubar(i ,j,krhs)+ &
1856# ifdef WEC_MELLOR
1857!^ & ubar_stokes(i ,j)+ &
1858!^ & ubar_stokes(i+1,j)+ &
1859# endif
1860!^ & ubar(i+1,j,krhs))
1861!^
1862 tl_vfe(i,j)=tl_cff*(ubar(i ,j,krhs)+ &
1863# ifdef WEC_MELLOR
1864 & ubar_stokes(i ,j)+ &
1865 & ubar_stokes(i+1,j)+ &
1866# endif
1867 & ubar(i+1,j,krhs))+ &
1868 & cff*(tl_ubar(i ,j,krhs)+ &
1869# ifdef WEC_MELLOR
1870 & tl_ubar_stokes(i ,j)+ &
1871 & tl_ubar_stokes(i+1,j)+ &
1872# endif
1873 & tl_ubar(i+1,j,krhs))
1874 END DO
1875 END DO
1876!
1877 DO j=jstr,jend
1878 DO i=istr,iend
1879 IF (i.ge.istru) THEN
1880!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
1881!^
1882 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
1883!^ rubar(i,j)=rubar(i,j)+fac1
1884!^
1885 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
1886# if defined DIAGNOSTICS_UV
1887!! DiaU2rhs(i,j,M2fcor)=fac1
1888# endif
1889 END IF
1890!
1891 IF (j.ge.jstrv) THEN
1892!^ fac2=0.5_r8*(VFe(i,j)+VFe(i,j-1))
1893!^
1894 tl_fac2=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
1895!^ rvbar(i,j)=rvbar(i,j)-fac2
1896!^
1897 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
1898# if defined DIAGNOSTICS_UV
1899!! DiaV2rhs(i,j,M2fcor)=-fac2
1900# endif
1901 END IF
1902 END DO
1903 END DO
1904#endif
1905
1906#if (defined CURVGRID && defined UV_ADV) && !defined SOLVE3D
1907!
1908!-----------------------------------------------------------------------
1909! Add in curvilinear transformation terms.
1910!-----------------------------------------------------------------------
1911!
1912 DO j=jstrv-1,jend
1913 DO i=istru-1,iend
1914 cff1=0.5_r8*(vbar(i,j ,krhs)+ &
1915# ifdef WEC_MELLOR
1916 & vbar_stokes(i,j )+ &
1917 & vbar_stokes(i,j+1)+ &
1918# endif
1919 & vbar(i,j+1,krhs))
1920 tl_cff1=0.5_r8*(tl_vbar(i,j ,krhs)+ &
1921# ifdef WEC_MELLOR
1922 & tl_vbar_stokes(i,j )+ &
1923 & tl_vbar_stokes(i,j+1)+ &
1924# endif
1925 & tl_vbar(i,j+1,krhs))
1926 cff2=0.5_r8*(ubar(i ,j,krhs)+ &
1927# ifdef WEC_MELLOR
1928 & ubar_stokes(i ,j)+ &
1929 & ubar_stokes(i+1,j)+ &
1930# endif
1931 & ubar(i+1,j,krhs))
1932 tl_cff2=0.5_r8*(tl_ubar(i ,j,krhs)+ &
1933# ifdef WEC_MELLOR
1934 & tl_ubar_stokes(i ,j)+ &
1935 & tl_ubar_stokes(i+1,j)+ &
1936# endif
1937 & tl_ubar(i+1,j,krhs))
1938 cff3=cff1*dndx(i,j)
1939 tl_cff3=tl_cff1*dndx(i,j)
1940 cff4=cff2*dmde(i,j)
1941 tl_cff4=tl_cff2*dmde(i,j)
1942 cff=drhs(i,j)*(cff3-cff4)
1943 tl_cff=tl_drhs(i,j)*(cff3-cff4)+ &
1944 & drhs(i,j)*(tl_cff3-tl_cff4)
1945!^ UFx(i,j)=cff*cff1
1946!^
1947 tl_ufx(i,j)=tl_cff*cff1+cff*tl_cff1
1948!^ VFe(i,j)=cff*cff2
1949!^
1950 tl_vfe(i,j)=tl_cff*cff2+cff*tl_cff2
1951# if defined DIAGNOSTICS_UV
1952!! cff=Drhs(i,j)*cff4
1953!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
1954!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
1955# endif
1956 END DO
1957 END DO
1958!
1959 DO j=jstr,jend
1960 DO i=istr,iend
1961 IF (i.ge.istru) THEN
1962!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
1963!^
1964 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
1965!^ rubar(i,j)=rubar(i,j)+fac1
1966!^
1967 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
1968# if defined DIAGNOSTICS_UV
1969!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
1970!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
1971!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
1972!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
1973# endif
1974 END IF
1975!
1976 IF (j.ge.jstrv) THEN
1977!^ fac1=0.5_r8*(VFe(i,j)+VFe(i,j-1))
1978!^
1979 tl_fac1=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
1980!^ rvbar(i,j)=rvbar(i,j)-fac1
1981!^
1982 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac1
1983# if defined DIAGNOSTICS_UV
1984!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
1985!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
1986!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
1987!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
1988# endif
1989 END IF
1990 END DO
1991 END DO
1992#endif
1993
1994#if defined UV_VIS2 && !defined SOLVE3D
1995!
1996!-----------------------------------------------------------------------
1997! Add in horizontal harmonic viscosity.
1998!-----------------------------------------------------------------------
1999!
2000! Compute total depth at PSI-points.
2001!
2002 DO j=jstr,jend+1
2003 DO i=istr,iend+1
2004 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2005 & drhs(i,j-1)+drhs(i-1,j-1))
2006 tl_drhs_p(i,j)=0.25_r8*(tl_drhs(i,j )+tl_drhs(i-1,j )+ &
2007 & tl_drhs(i,j-1)+tl_drhs(i-1,j-1))
2008 END DO
2009 END DO
2010!
2011! Compute flux-components of the horizontal divergence of the stress
2012! tensor (m5/s2) in XI- and ETA-directions.
2013!
2014 DO j=jstrv-1,jend
2015 DO i=istru-1,iend
2016!^ cff=visc2_r(i,j)*Drhs(i,j)*0.5_r8* &
2017!^ & (pmon_r(i,j)* &
2018!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2019!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2020!^ & pnom_r(i,j)* &
2021!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2022!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))
2023!^
2024 tl_cff=visc2_r(i,j)*0.5_r8* &
2025 & (tl_drhs(i,j)* &
2026 & (pmon_r(i,j)* &
2027 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2028 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2029 & pnom_r(i,j)* &
2030 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2031 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))+ &
2032 & drhs(i,j)* &
2033 & (pmon_r(i,j)* &
2034 & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2035 & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2036 & pnom_r(i,j)* &
2037 & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2038 & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs))))
2039!^ UFx(i,j)=on_r(i,j)*on_r(i,j)*cff
2040!^
2041 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2042!^ VFe(i,j)=om_r(i,j)*om_r(i,j)*cff
2043!^
2044 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2045 END DO
2046 END DO
2047!
2048 DO j=jstr,jend+1
2049 DO i=istr,iend+1
2050!^ cff=visc2_p(i,j)*Drhs_p(i,j)*0.5_r8* &
2051!^ & (pmon_p(i,j)* &
2052!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2053!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2054!^ & pnom_p(i,j)* &
2055!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2056!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))
2057!^
2058 tl_cff=visc2_p(i,j)*0.5_r8* &
2059 & (tl_drhs_p(i,j)* &
2060 & (pmon_p(i,j)* &
2061 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2062 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2063 & pnom_p(i,j)* &
2064 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2065 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))+ &
2066 & drhs_p(i,j)* &
2067 & (pmon_p(i,j)* &
2068 & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2069 & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2070 & pnom_p(i,j)* &
2071 & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2072 & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs))))
2073# ifdef MASKING
2074!^ cff=cff*pmask(i,j)
2075!^
2076 tl_cff=tl_cff*pmask(i,j
2077# endif
2078# ifdef WET_DRY_NOT_YET
2079!^ cff=cff*pmask_wet(i,j)
2080!^
2081 tl_cff=tl_cff*pmask_wet(i,j)
2082# endif
2083!^ UFe(i,j)=om_p(i,j)*om_p(i,j)*cff
2084!^
2085 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2086!^ VFx(i,j)=on_p(i,j)*on_p(i,j)*cff
2087!^
2088 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2089 END DO
2090 END DO
2091!
2092! Add in harmonic viscosity.
2093!
2094 DO j=jstr,jend
2095 DO i=istr,iend
2096 IF (i.ge.istru) THEN
2097!^ cff1=0.5_r8*(pn(i-1,j)+pn(i,j))*(UFx(i,j )-UFx(i-1,j))
2098!^
2099 tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2100 & (tl_ufx(i,j )-tl_ufx(i-1,j))
2101!^ cff2=0.5_r8*(pm(i-1,j)+pm(i,j))*(UFe(i,j+1)-UFe(i ,j))
2102!^
2103 tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2104 & (tl_ufe(i,j+1)-tl_ufe(i ,j))
2105!^ fac=cff1+cff2
2106!^
2107 tl_fac=tl_cff1+tl_cff2
2108!^ rubar(i,j)=rubar(i,j)+fac
2109!^
2110 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac
2111# if defined DIAGNOSTICS_UV
2112!! DiaU2rhs(i,j,M2hvis)=fac
2113!! DiaU2rhs(i,j,M2xvis)=cff1
2114!! DiaU2rhs(i,j,M2yvis)=cff2
2115# endif
2116 END IF
2117!
2118 IF (j.ge.jstrv) THEN
2119!^ cff1=0.5_r8*(pn(i,j-1)+pn(i,j))*(VFx(i+1,j)-VFx(i,j ))
2120!^
2121 tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2122 & (tl_vfx(i+1,j)-tl_vfx(i,j ))
2123!^ cff2=0.5_r8*(pm(i,j-1)+pm(i,j))*(VFe(i ,j)-VFe(i,j-1))
2124!^
2125 tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2126 & (tl_vfe(i ,j)-tl_vfe(i,j-1))
2127!^ fac=cff1-cff2
2128!^
2129 tl_fac=tl_cff1-tl_cff2
2130!^ rvbar(i,j)=rvbar(i,j)+fac
2131!^
2132 tl_rvbar(i,j)=tl_rvbar(i,j)+tl_fac
2133# if defined DIAGNOSTICS_UV
2134!! DiaV2rhs(i,j,M2hvis)=fac
2135!! DiaV2rhs(i,j,M2xvis)= cff1
2136!! DiaV2rhs(i,j,M2yvis)=-cff2
2137# endif
2138 END IF
2139 END DO
2140 END DO
2141#endif
2142
2143#ifndef SOLVE3D
2144!
2145!-----------------------------------------------------------------------
2146! Add in bottom stress.
2147!-----------------------------------------------------------------------
2148!
2149 DO j=jstr,jend
2150 DO i=istru,iend
2151!^ fac=bustr(i,j)*om_u(i,j)*on_u(i,j)
2152!^
2153 tl_fac=tl_bustr(i,j)*om_u(i,j)*on_u(i,j)
2154!^ rubar(i,j)=rubar(i,j)-fac
2155!^
2156 tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
2157# ifdef DIAGNOSTICS_UV
2158!! DiaU2rhs(i,j,M2bstr)=-fac
2159# endif
2160 END DO
2161 END DO
2162 DO j=jstrv,jend
2163 DO i=istr,iend
2164!^ fac=bvstr(i,j)*om_v(i,j)*on_v(i,j)
2165!^
2166 tl_fac=tl_bvstr(i,j)*om_v(i,j)*on_v(i,j)
2167!^ rvbar(i,j)=rvbar(i,j)-fac
2168!^
2169 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
2170# ifdef DIAGNOSTICS_UV
2171!! DiaV2rhs(i,j,M2bstr)=-fac
2172# endif
2173 END DO
2174 END DO
2175#else
2176# ifdef DIAGNOSTICS_UV
2177!!
2178!! Initialize the stress term if no bottom friction is defined.
2179!!
2180!! DO j=Jstr,Jend
2181!! DO i=IstrU,Iend
2182!! DiaU2rhs(i,j,M2bstr)=0.0_r8
2183!! END DO
2184!! END DO
2185!! DO j=JstrV,Jend
2186!! DO i=Istr,Iend
2187!! DiaV2rhs(i,j,M2bstr)=0.0_r8
2188!! END DO
2189!! END DO
2190# endif
2191#endif
2192
2193#ifdef SOLVE3D
2194!
2195!-----------------------------------------------------------------------
2196! Coupling between 2D and 3D equations.
2197!-----------------------------------------------------------------------
2198!
2199! Before the predictor step of the first barotropic time step, arrays
2200! "rufrc" and "rvfrc" contain vertical integrals of the 3D RHS terms
2201! for the momentum equations (including surface and bottom stresses,
2202! if so prescribed). During the first barotropic time step, convert
2203! them into forcing terms by subtracting the fast-time "rubar" and
2204! "rvbar" from them.
2205!
2206! These forcing terms are then extrapolated forward in time using
2207! optimized Adams-Bashforth weights, so that the resultant "rufrc"
2208! and "rvfrc" are centered effectively at time n+1/2 in baroclinic
2209! time.
2210!
2211! From now on, these newly computed forcing terms remain unchanged
2212! during the fast time stepping and will be added to "rubar" and
2213! "rvbar" during all subsequent barotropic time steps.
2214!
2215! Thus, the algorithm below is designed for coupling during the 3D
2216! predictor sub-step. The forcing terms "rufrc" and "rvfrc" are
2217! computed as instantaneous values at 3D time index "nstp" first and
2218! then extrapolated half-step forward using AM3-like weights optimized
2219! for maximum stability (with particular care for startup).
2220!
2221 IF (first_2d_step.and.predictor_2d_step) THEN
2222 IF (first_time_step) THEN
2223 cff3=0.0_r8
2224 cff2=0.0_r8
2225 cff1=1.0_r8
2226 ELSE IF (first_time_step+1) THEN
2227 cff3=0.0_r8
2228 cff2=-0.5_r8
2229 cff1=1.5_r8
2230 ELSE
2231 cff3=0.281105_r8
2232 cff2=-0.5_r8-2.0_r8*cff3
2233 cff1=1.5_r8+cff3
2234 END IF
2235!
2236 DO j=jstr,jend
2237 DO i=istru,iend
2238!^ cff=rufrc(i,j)-rubar(i,j)
2239!^
2240 tl_cff=tl_rufrc(i,j)-tl_rubar(i,j)
2241!^ rufrc(i,j)=cff1*cff+ &
2242!^ & cff2*rufrc_bak(i,j,3-nstp)+ &
2243!^ & cff3*rufrc_bak(i,j,nstp )
2244!^
2245 tl_rufrc(i,j)=cff1*tl_cff+ &
2246 & cff2*tl_rufrc_bak(i,j,3-nstp)+ &
2247 & cff3*tl_rufrc_bak(i,j,nstp )
2248!^ rufrc_bak(i,j,nstp)=cff
2249!^
2250 tl_rufrc_bak(i,j,nstp)=tl_cff
2251 END DO
2252 END DO
2253 DO j=jstrv,jend
2254 DO i=istr,iend
2255!^ cff=rvfrc(i,j)-rvbar(i,j)
2256!^
2257 tl_cff=tl_rvfrc(i,j)-tl_rvbar(i,j)
2258!^ rvfrc(i,j)=cff1*cff+ &
2259!^ & cff2*rvfrc_bak(i,j,3-nstp)+ &
2260!^ & cff3*rvfrc_bak(i,j,nstp )
2261!^
2262 tl_rvfrc(i,j)=cff1*tl_cff+ &
2263 & cff2*tl_rvfrc_bak(i,j,3-nstp)+ &
2264 & cff3*tl_rvfrc_bak(i,j,nstp )
2265!^ rvfrc_bak(i,j,nstp)=cff
2266!^
2267 tl_rvfrc_bak(i,j,nstp)=tl_cff
2268 END DO
2269 END DO
2270!
2271! Since coupling requires that the pressure gradient term is computed
2272! using zeta(:,:,kstp) instead of 1/3 toward zeta_new(:,:) as needed
2273! by generalized RK2 scheme, apply compensation to shift pressure
2274! gradient terms from "kstp" to 1/3 toward "knew".
2275!
2276 cff1=0.5_r8*g
2277 cff2=0.333333333333_r8
2278 cff3=1.666666666666_r8
2279
2280 DO j=jstrv-1,jend
2281 DO i=istru-1,iend
2282!^ zwrk(i,j)=cff2*(zeta_new(i,j)-zeta(i,j,kstp))
2283!^
2284 tl_zwrk(i,j)=cff2*(tl_zeta_new(i,j)-tl_zeta(i,j,kstp))
2285# if defined VAR_RHO_2D && defined SOLVE3D
2286!^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j)
2287!^
2288 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
2289 & tl_rhos(i,j)*zwrk(i,j)
2290!^ rzeta2(i,j)=rzeta(i,j)* &
2291!^ & (cff2*zeta_new(i,j)+ &
2292!^ & cff3*zeta(i,j,kstp))
2293!^
2294 tl_rzeta2(i,j)=tl_rzeta(i,j)* &
2295 & (cff2*zeta_new(i,j)+ &
2296 & cff3*zeta(i,j,kstp))+ &
2297 & rzeta(i,j)* &
2298 & (cff2*tl_zeta_new(i,j)+ &
2299 & cff3*tl_zeta(i,j,kstp))
2300!^ rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))
2301!^
2302 tl_rzetasa(i,j)=tl_zwrk(i,j)* &
2303 & (rhos(i,j)-rhoa(i,j))+ &
2304 & zwrk(i,j)* &
2305 & (tl_rhos(i,j)-tl_rhoa(i,j))
2306# else
2307!^ rzeta(i,j)=zwrk(i,j)
2308!^
2309 tl_rzeta(i,j)=tl_zwrk(i,j)
2310!^ rzeta2(i,j)=zwrk(i,j)* &
2311!^ & (cff2*zeta_new(i,j)+ &
2312!^ & cff3*zeta(i,j,kstp))
2313!^
2314 tl_rzeta2(i,j)=tl_zwrk(i,j)* &
2315 & (cff2*zeta_new(i,j)+ &
2316 & cff3*zeta(i,j,kstp))+ &
2317 & zwrk(i,j)* &
2318 & (cff2*tl_zeta_new(i,j)+ &
2319 & cff3*tl_zeta(i,j,kstp))
2320# endif
2321 END DO
2322 END DO
2323!
2324 DO j=jstr,jend
2325 DO i=istr,iend
2326 IF (i.ge.istru) THEN
2327!^ rubar(i,j)=rubar(i,j)+ &
2328!^ & cff1*on_u(i,j)* &
2329!^ & ((h(i-1,j)+ &
2330!^ & h(i ,j))* &
2331!^ & (rzeta(i-1,j)- &
2332!^ & rzeta(i ,j))+ &
2333# if defined VAR_RHO_2D && defined SOLVE3D
2334!^ & (h(i-1,j)- &
2335!^ & h(i ,j))* &
2336!^ & (rzetaSA(i-1,j)+ &
2337!^ & rzetaSA(i ,j)+ &
2338!^ & cff2*(rhoA(i-1,j)- &
2339!^ & rhoA(i ,j))* &
2340!^ & (zwrk(i-1,j)- &
2341!^ & zwrk(i ,j)))+ &
2342# endif
2343!^ & (rzeta2(i-1,j)- &
2344!^ & rzeta2(i ,j)))
2345!^
2346 tl_rubar(i,j)=tl_rubar(i,j)+ &
2347 & cff1*on_u(i,j)* &
2348 & ((tl_h(i-1,j)+ &
2349 & tl_h(i ,j))* &
2350 & (rzeta(i-1,j)- &
2351 & rzeta(i ,j))+ &
2352 & (h(i-1,j)+ &
2353 & h(i ,j))* &
2354 & (tl_rzeta(i-1,j)- &
2355 & tl_rzeta(i ,j))+ &
2356# if defined VAR_RHO_2D && defined SOLVE3D
2357 & (tl_h(i-1,j)- &
2358 & tl_h(i ,j))* &
2359 & (rzetasa(i-1,j)+ &
2360 & rzetasa(i ,j)+ &
2361 & cff2*(rhoa(i-1,j)- &
2362 & rhoa(i ,j))* &
2363 & (zwrk(i-1,j)- &
2364 & zwrk(i ,j)))+ &
2365 & (h(i-1,j)- &
2366 & h(i ,j))* &
2367 & (tl_rzetasa(i-1,j)+ &
2368 & tl_rzetasa(i ,j)+ &
2369 & cff2*((tl_rhoa(i-1,j)- &
2370 & tl_rhoa(i ,j))* &
2371 & (zwrk(i-1,j)- &
2372 & zwrk(i ,j))+ &
2373 & (rhoa(i-1,j)- &
2374 & rhoa(i ,j))* &
2375 & (tl_zwrk(i-1,j)- &
2376 & tl_zwrk(i ,j))))+ &
2377# endif
2378 & (tl_rzeta2(i-1,j)- &
2379 & tl_rzeta2(i ,j)))
2380# ifdef DIAGNOSTICS_UV
2381!! DiaU2rhs(i,j,M2pgrd)=DiaU2rhs(i,j,M2pgrd)+ &
2382!! & rubar(i,j)
2383# endif
2384 END IF
2385!
2386 IF (j.ge.jstrv) THEN
2387!^ rvbar(i,j)=rvbar(i,j)+ &
2388!^ & cff1*om_v(i,j)* &
2389!^ & ((h(i,j-1)+ &
2390!^ & h(i,j ))* &
2391!^ & (rzeta(i,j-1)- &
2392!^ & rzeta(i,j ))+ &
2393# if defined VAR_RHO_2D && defined SOLVE3D
2394!^ & (h(i,j-1)- &
2395!^ & h(i,j ))* &
2396!^ & (rzetaSA(i,j-1)+ &
2397!^ & rzetaSA(i,j )+ &
2398!^ & cff2*(rhoA(i,j-1)- &
2399!^ & rhoA(i,j ))* &
2400!^ & (zwrk(i,j-1)- &
2401!^ & zwrk(i,j )))+ &
2402# endif
2403!^ & (rzeta2(i,j-1)- &
2404!^ & rzeta2(i,j )))
2405!^
2406 tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2407 & cff1*om_v(i,j)* &
2408 & ((tl_h(i,j-1)+ &
2409 & tl_h(i,j ))* &
2410 & (rzeta(i,j-1)- &
2411 & rzeta(i,j ))+ &
2412 & (h(i,j-1)+ &
2413 & h(i,j ))* &
2414 & (tl_rzeta(i,j-1)- &
2415 & tl_rzeta(i,j ))+ &
2416# if defined VAR_RHO_2D && defined SOLVE3D
2417 & (tl_h(i,j-1)- &
2418 & tl_h(i,j ))* &
2419 & (rzetasa(i,j-1)+ &
2420 & rzetasa(i,j )+ &
2421 & cff2*(rhoa(i,j-1)- &
2422 & rhoa(i,j ))* &
2423 & (zwrk(i,j-1)- &
2424 & zwrk(i,j )))+ &
2425 & (h(i,j-1)- &
2426 & h(i,j ))* &
2427 & (tl_rzetasa(i,j-1)+ &
2428 & tl_rzetasa(i,j )+ &
2429 & cff2*((tl_rhoa(i,j-1)- &
2430 & tl_rhoa(i,j ))* &
2431 & (zwrk(i,j-1)- &
2432 & zwrk(i,j ))+ &
2433 & (rhoa(i,j-1)- &
2434 & rhoa(i,j ))* &
2435 & (tl_zwrk(i,j-1)- &
2436 & tl_zwrk(i,j ))))+ &
2437# endif
2438 & (tl_rzeta2(i,j-1)- &
2439 & tl_rzeta2(i,j )))
2440# ifdef DIAGNOSTICS_UV
2441!! DiaV2rhs(i,j,M2pgrd)=DiaV2rhs(i,j,M2pgrd)+ &
2442!! & rvbar(i,j)
2443# endif
2444 END IF
2445 END DO
2446 END DO
2447 END IF
2448#endif
2449!
2450!=======================================================================
2451! Time step 2D momentum equations.
2452!=======================================================================
2453!
2454! Compute total water column depth.
2455!
2456 IF (first_2d_step.or.(.not.predictor_2d_step)) THEN
2457 DO j=jstrv-1,jend
2458 DO i=istru-1,iend
2459!^ Dstp(i,j)=h(i,j)+zeta(i,j,kstp)
2460!^
2461 tl_dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kstp)
2462 END DO
2463 END DO
2464 ELSE
2465 DO j=jstrv-1,jend
2466 DO i=istru-1,iend
2467!^ Dstp(i,j)=h(i,j)+zeta(i,j,kbak)
2468!^
2469 tl_dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kbak)
2470 END DO
2471 END DO
2472 END IF
2473!
2474! During the predictor sub-step, once newly computed "ubar" and "vbar"
2475! become available, interpolate them half-step backward in barotropic
2476! time (i.e., they end up time-centered at n+1/2) in order to use it
2477! during subsequent corrector sub-step.
2478!
2479 IF (predictor_2d_step) THEN
2480 IF (first_2d_step) THEN
2481 cff1=0.5_r8*dtfast(ng)
2482 cff2=0.5_r8
2483 cff3=0.5_r8
2484 cff4=0.0_r8
2485 ELSE
2486 cff1=dtfast(ng)
2487 cff2=0.5_r8-gamma
2488 cff3=0.5_r8+2.0_r8*gamma
2489 cff4=-gamma
2490 ENDIF
2491!
2492 DO j=jstr,jend
2493 DO i=istru,iend
2494 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
2495 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
2496 tl_fac1=-fac1*fac1*(tl_dnew(i,j)+tl_dnew(i-1,j))
2497!^ ubar(i,j,knew)=fac1* &
2498!^ & (ubar(i,j,kbak)* &
2499!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2500#ifdef SOLVE3D
2501!^ & cff*(rubar(i,j)+rufrc(i,j)))
2502#else
2503!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
2504#endif
2505!^
2506 tl_ubar(i,j,knew)=tl_fac1* &
2507 & (ubar(i,j,kbak)* &
2508 & (dstp(i,j)+dstp(i-1,j))+ &
2509#ifdef SOLVE3D
2510 & cff*(rubar(i,j)+rufrc(i,j)))+ &
2511#else
2512 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
2513#endif
2514 & fac1* &
2515 & (tl_ubar(i,j,kbak)* &
2516 & (dstp(i,j)+dstp(i-1,j))+ &
2517 & ubar(i,j,kbak)* &
2518 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
2519#ifdef SOLVE3D
2520 & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))
2521#else
2522 & cff*tl_rubar(i,j)+ &
2523 & 4.0_r8*cff1*tl_sustr(i,j))
2524#endif
2525#ifdef MASKING
2526!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
2527!^
2528 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
2529#endif
2530!^ ubar(i,j,knew)=cff2*ubar(i,j,knew)+ &
2531!^ & cff3*ubar(i,j,kstp)+ &
2532!^ & cff4*ubar(i,j,kbak)
2533!^
2534 tl_ubar(i,j,knew)=cff2*tl_ubar(i,j,knew)+ &
2535 & cff3*tl_ubar(i,j,kstp)+ &
2536 & cff4*tl_ubar(i,j,kbak)
2537#ifdef WET_DRY_NOT_YET
2538!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
2539!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
2540!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2541!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
2542!^
2543!^ HGA: TLM code needed here.
2544!^
2545#endif
2546#if defined NESTING && !defined SOLVE3D
2547!^ DU_flux(i,j)=0.5_r8*on_u(i,j)* &
2548!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2549!^
2550 tl_du_flux(i,j)=0.5_r8*on_u(i,j)* &
2551 & ((dnew(i,j)+dnew(i-1,j))* &
2552 & tl_ubar(i,j,knew)+ &
2553 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2554 & ubar(i,j,knew))
2555#endif
2556 END DO
2557 END DO
2558!
2559 DO j=jstrv,jend
2560 DO i=istr,iend
2561 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
2562 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
2563 tl_fac2=-fac2*fac2*(tl_dnew(i,j)+tl_dnew(i,j-1))
2564!^ vbar(i,j,knew)=fac2* &
2565!^ & (vbar(i,j,kbak)* &
2566!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
2567#ifdef SOLVE3D
2568!^ & cff*(rvbar(i,j)+rvfrc(i,j)))
2569#else
2570!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
2571#endif
2572!^
2573 tl_vbar(i,j,knew)=tl_fac2* &
2574 & (vbar(i,j,kbak)* &
2575 & (dstp(i,j)+dstp(i,j-1))+ &
2576#ifdef SOLVE3D
2577 & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
2578#else
2579 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
2580#endif
2581 & fac2* &
2582 & (tl_vbar(i,j,kbak)* &
2583 & (dstp(i,j)+dstp(i,j-1))+ &
2584 & vbar(i,j,kbak)* &
2585 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
2586#ifdef SOLVE3D
2587 & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
2588#else
2589 & cff*tl_rvbar(i,j)+ &
2590 & 4.0_r8*cff1*tl_svstr(i,j))
2591#endif
2592#ifdef MASKING
2593!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
2594!^
2595 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
2596#endif
2597!^ vbar(i,j,knew)=cff2*vbar(i,j,knew)+ &
2598!^ & cff3*vbar(i,j,kstp)+ &
2599!^ & cff4*vbar(i,j,kbak)
2600!^
2601 tl_vbar(i,j,knew)=cff2*tl_vbar(i,j,knew)+ &
2602 & cff3*tl_vbar(i,j,kstp)+ &
2603 & cff4*tl_vbar(i,j,kbak)
2604#ifdef WET_DRY_NOT_YET
2605!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
2606!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
2607!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2608!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
2609!^
2610!^ HGA: TLM code needed here.
2611!^
2612#endif
2613#if defined NESTING && !defined SOLVE3D
2614!^ DV_flux(i,j)=0.5_r8*om_v(i,j)* &
2615!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
2616!^
2617 tl_dv_flux(i,j)=0.5_r8*om_v(i,j)* &
2618 & ((dnew(i,j)+dnew(i,j-1))* &
2619 & tl_vbar(i,j,knew)+ &
2620 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
2621 & vbar(i,j,knew))
2622#endif
2623 END DO
2624 END DO
2625
2626 ELSE !--> CORRECTOR_2D_STEP
2627
2628 cff1=0.5_r8*dtfast(ng)
2629 DO j=jstr,jend
2630 DO i=istru,iend
2631 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
2632 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
2633 tl_fac1=-fac1*fac1*(dnew(i,j)+dnew(i-1,j))
2634!^ ubar(i,j,knew)=fac1* &
2635!^ & (ubar(i,j,kstp)* &
2636!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2637#ifdef SOLVE3D
2638!^ & cff*(rubar(i,j)+rufrc(i,j)))
2639#else
2640!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
2641#endif
2642!^
2643 tl_ubar(i,j,knew)=tl_fac1* &
2644 & (ubar(i,j,kstp)* &
2645 & (dstp(i,j)+dstp(i-1,j))+ &
2646#ifdef SOLVE3D
2647 & cff*(rubar(i,j)+rufrc(i,j)))+ &
2648#else
2649 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
2650#endif
2651 & fac1* &
2652 & (tl_ubar(i,j,kstp)* &
2653 & (dstp(i,j)+dstp(i-1,j))+ &
2654 & ubar(i,j,kstp)* &
2655 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
2656#ifdef SOLVE3D
2657 & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))
2658#else
2659 & cff*tl_rubar(i,j)+ &
2660 & 4.0_r8*cff1*tl_sustr(i,j))
2661#endif
2662#ifdef MASKING
2663!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
2664!^
2665 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
2666#endif
2667#ifdef WET_DRY_NOT_YET
2668!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
2669!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
2670!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2671!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
2672!^
2673!^ HGA: TLM code needed here.
2674!^
2675#endif
2676#if defined NESTING && !defined SOLVE3D
2677!^ DU_flux(i,j)=0.5_r8*on_u(i,j)* &
2678!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2679!^
2680 tl_du_flux(i,j)=0.5_r8*on_u(i,j)* &
2681 & ((dnew(i,j)+dnew(i-1,j))* &
2682 & tl_ubar(i,j,knew)+ &
2683 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2684 & ubar(i,j,knew))
2685#endif
2686 END DO
2687 END DO
2688!
2689 DO j=jstrv,jend
2690 DO i=istr,iend
2691 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
2692 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
2693 tl_fac2=-fac2*fac2*(tl_dnew(i,j)+tl_dnew(i,j-1))
2694!^ vbar(i,j,knew)=fac2* &
2695!^ & (vbar(i,j,kstp)* &
2696!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
2697#ifdef SOLVE3D
2698!^ & cff*(rvbar(i,j)+rvfrc(i,j)))
2699#else
2700!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
2701#endif
2702!^
2703 tl_vbar(i,j,knew)=tl_fac2* &
2704 & (vbar(i,j,kstp)* &
2705 & (dstp(i,j)+dstp(i,j-1))+ &
2706#ifdef SOLVE3D
2707 & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
2708#else
2709 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
2710#endif
2711 & fac2* &
2712 & (tl_vbar(i,j,kstp)* &
2713 & (dstp(i,j)+dstp(i,j-1))+ &
2714 & vbar(i,j,kstp)* &
2715 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
2716#ifdef SOLVE3D
2717 & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
2718#else
2719 & cff*tl_rvbar(i,j)+ &
2720 & 4.0_r8*cff1*svstr(i,j))
2721#endif
2722#ifdef MASKING
2723!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
2724!^
2725 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
2726#endif
2727#ifdef WET_DRY_NOT_YET
2728!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
2729!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
2730!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2731!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
2732!^
2733!^ HGA: TLM code needed here.
2734!^
2735#endif
2736#if defined NESTING && !defined SOLVE3D
2737!^ DV_flux(i,j)=0.5_r8*om_v(i,j)* &
2738!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
2739!^
2740 tl_dv_flux(i,j)=0.5_r8*om_v(i,j)* &
2741 & ((dnew(i,j)+dnew(i,j-1))* &
2742 & tl_vbar(i,j,knew)+ &
2743 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
2744 & vbar(i,j,knew))
2745#endif
2746 END DO
2747 END DO
2748 END IF
2749!
2750! Apply lateral boundary conditions.
2751!
2752!^ CALL u2dbc_tile (ng, tile, &
2753!^ & LBi, UBi, LBj, UBj, &
2754!^ & IminS, ImaxS, JminS, JmaxS, &
2755!^ & krhs, kstp, knew, &
2756!^ & ubar, vbar, zeta)
2757!^
2758 CALL tl_u2dbc_tile (ng, tile, &
2759 & lbi, ubi, lbj, ubj, &
2760 & imins, imaxs, jmins, jmaxs, &
2761 & krhs, kstp, knew, &
2762 & ubar, vbar, zeta, &
2763 & tl_ubar, tl_vbar, tl_zeta)
2764!^ CALL v2dbc_tile (ng, tile, &
2765!^ & LBi, UBi, LBj, UBj, &
2766!^ & IminS, ImaxS, JminS, JmaxS, &
2767!^ & krhs, kstp, knew, &
2768!^ & ubar, vbar, zeta)
2769!^
2770 CALL tl_v2dbc_tile (ng, tile, &
2771 & lbi, ubi, lbj, ubj, &
2772 & imins, imaxs, jmins, jmaxs, &
2773 & krhs, kstp, knew, &
2774 & ubar, vbar, zeta, &
2775 & tl_ubar, tl_vbar, tl_zeta)
2776!
2777! Compute integral mass flux across open boundaries and adjust
2778! for volume conservation.
2779!
2780 IF (any(volcons(:,ng))) THEN
2781!^ CALL obc_flux_tile (ng, tile, &
2782!^ & LBi, UBi, LBj, UBj, &
2783!^ & IminS, ImaxS, JminS, JmaxS, &
2784!^ & knew, &
2785#ifdef MASKING
2786!^ & umask, vmask, &
2787#endif
2788!^ & h, om_v, on_u, &
2789!^ & ubar, vbar, zeta)
2790!^
2791 CALL tl_obc_flux_tile (ng, tile, &
2792 & lbi, ubi, lbj, ubj, &
2793 & imins, imaxs, jmins, jmaxs, &
2794 & knew, &
2795#ifdef MASKING
2796 & umask, vmask, &
2797#endif
2798 & h, tl_h, om_v, on_u, &
2799 & ubar, vbar, zeta, &
2800 & tl_ubar, tl_vbar, tl_zeta)
2801 END IF
2802
2803#if defined NESTING && !defined SOLVE3D
2804!
2805! Set barotropic fluxes along physical boundaries.
2806!
2807 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2808 IF (domain(ng)%Western_Edge(tile)) THEN
2809 DO j=jstr-1,jendr
2810!^ Dnew(Istr-1,j)=h(Istr-1,j)+zeta_new(Istr-1,j)
2811!^
2812 tl_dnew(istr-1,j)=tl_h(istr-1,j)+tl_zeta_new(istr-1,j)
2813 END DO
2814 END IF
2815 END IF
2816 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2817 IF (domain(ng)%Eastern_Edge(tile)) THEN
2818 DO j=jstr-1,jendr
2819!^ Dnew(Iend+1,j)=h(Iend+1,j)+zeta_new(Iend+1,j)
2820!^
2821 tl_dnew(iend+1,j)=tl_h(iend+1,j)+tl_zeta_new(iend+1,j)
2822 END DO
2823 END IF
2824 END IF
2825 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2826 IF (domain(ng)%Southern_Edge(tile)) THEN
2827 DO i=istr-1,iendr
2828!^ Dnew(i,Jstr-1)=h(i,Jstr-1)+zeta_new(i,Jstr-1)
2829!^
2830 tl_dnew(i,jstr-1)=tl_h(i,jstr-1)+tl_zeta_new(i,jstr-1)
2831 END DO
2832 END IF
2833 END IF
2834 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2835 IF (domain(ng)%Northern_Edge(tile)) THEN
2836 DO i=istr-1,iendr
2837!^ Dnew(i,Jend+1)=h(i,Jend+1)+zeta_new(i,Jend+1)
2838!^
2839 tl_dnew(i,jend+1)=tl_h(i,jend+1)+tl_zeta_new(i,jend+1)
2840 END DO
2841 END IF
2842 END IF
2843!
2844 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2845 IF (domain(ng)%Western_Edge(tile)) THEN
2846 DO j=jstrr,jendr
2847!^ DU_flux(IstrU-1,j)=0.5_r8*on_u(IstrU-1,j)* &
2848!^ & (Dnew(IstrU-1,j)+Dnew(IstrU-2,j))* &
2849!^ & ubar(IstrU-1,j,knew)
2850!^
2851 tl_du_flux(istru-1,j)=0.5_r8*on_u(istru-1,j)* &
2852 & ((dnew(istru-1,j)+ &
2853 & dnew(istru-2,j))* &
2854 & tl_ubar(istru-1,j,knew)+ &
2855 & (tl_dnew(istru-1,j)+ &
2856 & tl_dnew(istru-2,j))* &
2857 & ubar(istru-1,j,knew))
2858 END DO
2859 DO j=jstrv,jend
2860!^ DV_flux(Istr-1,j)=0.5_r8*om_v(Istr-1,j)* &
2861!^ & (Dnew(Istr-1,j)+Dnew(Istr-1,j-1))* &
2862!^ & vbar(Istr-1,j,knew)
2863!^
2864 tl_dv_flux(istr-1,j)=0.5_r8*om_v(istr-1,j)* &
2865 & ((dnew(istr-1,j )+ &
2866 & dnew(istr-1,j-1))* &
2867 & tl_vbar(istr-1,j,knew)+ &
2868 & (tl_dnew(istr-1,j )+ &
2869 & tl_dnew(istr-1,j-1))* &
2870 & vbar(istr-1,j,knew))
2871 END DO
2872 END IF
2873 END IF
2874 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2875 IF (domain(ng)%Eastern_Edge(tile)) THEN
2876 DO j=jstrr,jendr
2877!^ DU_flux(Iend+1,j)=0.5_r8*on_u(Iend+1,j)* &
2878!^ & (Dnew(Iend+1,j)+Dnew(Iend,j))* &
2879!^ & ubar(Iend+1,j,knew)
2880!^
2881 tl_du_flux(iend+1,j)=0.5_r8*on_u(iend+1,j)* &
2882 & ((dnew(iend+1,j)+ &
2883 & dnew(iend ,j))* &
2884 & tl_ubar(iend+1,j,knew)+ &
2885 & (tl_dnew(iend+1,j)+ &
2886 & tl_dnew(iend ,j))* &
2887 & ubar(iend+1,j,knew))
2888 END DO
2889 DO j=jstrv,jend
2890!^ DV_flux(Iend+1,j)=0.5_r8*om_v(Iend+1,j)* &
2891!^ & (Dnew(Iend+1,j)+Dnew(Iend+1,j-1))* &
2892!^ & vbar(Iend+1,j,knew)
2893!^
2894 tl_dv_flux(iend+1,j)=0.5_r8*om_v(iend+1,j)* &
2895 & ((dnew(iend+1,j )+ &
2896 & dnew(iend+1,j-1))* &
2897 & tl_vbar(iend+1,j,knew)+ &
2898 & (tl_dnew(iend+1,j )+ &
2899 & tl_dnew(iend+1,j-1))* &
2900 & vbar(iend+1,j,knew))
2901 END DO
2902 END IF
2903 END IF
2904 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2905 IF (domain(ng)%Southern_Edge(tile)) THEN
2906 DO i=istru,iend
2907!^ DU_flux(i,Jstr-1)=0.5_r8*on_u(i,Jstr-1)* &
2908!^ & (Dnew(i,Jstr-1)+Dnew(i-1,Jstr-1))* &
2909!^ & ubar(i,Jstr-1,knew)
2910!^
2911 tl_du_flux(i,jstr-1)=0.5_r8*on_u(i,jstr-1)* &
2912 & ((dnew(i ,jstr-1)+ &
2913 & dnew(i-1,jstr-1))* &
2914 & tl_ubar(i,jstr-1,knew)+ &
2915 & (tl_dnew(i ,jstr-1)+ &
2916 & tl_dnew(i-1,jstr-1))* &
2917 & ubar(i,jstr-1,knew))
2918 END DO
2919 DO i=istrr,iendr
2920!^ DV_flux(i,JstrV-1)=0.5_r8*om_v(i,JstrV-1)* &
2921!^ & (Dnew(i,JstrV-1)+Dnew(i,JstrV-2))* &
2922!^ & vbar(i,JstrV-1,knew)
2923!^
2924 tl_dv_flux(i,jstrv-1)=0.5_r8*om_v(i,jstrv-1)* &
2925 & ((dnew(i,jstrv-1)+ &
2926 & dnew(i,jstrv-2))* &
2927 & tl_vbar(i,jstrv-1,knew)+ &
2928 & (tl_dnew(i,jstrv-1)+ &
2929 & tl_dnew(i,jstrv-2))* &
2930 & vbar(i,jstrv-1,knew))
2931 END DO
2932 END IF
2933 END IF
2934 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2935 IF (domain(ng)%Northern_Edge(tile)) THEN
2936 DO i=istru,iend
2937!^ DU_flux(i,Jend+1)=0.5_r8*on_u(i,Jend+1)* &
2938!^ & (Dnew(i,Jend+1)+Dnew(i-1,Jend+1))* &
2939!^ & ubar(i,Jend+1,knew)
2940!^
2941 tl_du_flux(i,jend+1)=0.5_r8*on_u(i,jend+1)* &
2942 & ((dnew(i ,jend+1)+ &
2943 & dnew(i-1,jend+1))* &
2944 & tl_ubar(i,jend+1,knew)+ &
2945 & (tl_dnew(i ,jend+1)+ &
2946 & tl_dnew(i-1,jend+1))* &
2947 & ubar(i,jend+1,knew))
2948 END DO
2949 DO i=istrr,iendr
2950!^ DV_flux(i,Jend+1)=0.5_r8*om_v(i,Jend+1)* &
2951!^ & (Dnew(i,Jend+1)+Dnew(i,Jend))* &
2952!^ & vbar(i,Jend+1,knew)
2953!^
2954 tl_dv_flux(i,jend+1)=0.5_r8*om_v(i,jend+1)* &
2955 & ((dnew(i,jend+1)+ &
2956 & dnew(i,jend ))* &
2957 & tl_vbar(i,jend+1,knew)+ &
2958 & (tl_dnew(i,jend+1)+ &
2959 & tl_dnew(i,jend ))* &
2960 & vbar(i,jend+1,knew))
2961 END DO
2962 END IF
2963 END IF
2964#endif
2965!
2966! Apply momentum transport point sources (like river runoff), if any.
2967!
2968! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
2969! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
2970!
2971 IF (luvsrc(ng)) THEN
2972 DO is=1,nsrc(ng)
2973 i=sources(ng)%Isrc(is)
2974 j=sources(ng)%Jsrc(is)
2975 IF (((istrr.le.i).and.(i.le.iendr)).and. &
2976 & ((jstrr.le.j).and.(j.le.jendr))) THEN
2977 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
2978 cff=1.0_r8/(on_u(i,j)* &
2979 & 0.5_r8*(dnew(i-1,j)+dnew(i,j)))
2980 tl_cff=-cff*cff*on_u(i,j)* &
2981 & 0.5_r8*(tl_dnew(i-1,j)+tl_dnew(i ,j))
2982!^ ubar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
2983!^
2984 tl_ubar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
2985 & sources(ng)%Qbar(is)*tl_cff
2986#ifdef SOLVE3D
2987!^ DU_avg1(i,j)=SOURCES(ng)%Qbar(is)
2988!^
2989 tl_du_avg1(i,j)=sources(ng)%tl_Qbar(is)
2990#endif
2991#if defined NESTING && !defined SOLVE3D
2992!^ DU_flux(i,j)=SOURCES(ng)%Qbar(is)
2993!^
2994 tl_du_flux(i,j)=sources(ng)%tl_Qbar(is)
2995#endif
2996 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
2997 cff=1.0_r8/(om_v(i,j)* &
2998 & 0.5_r8*(dnew(i,j-1)+dnew(i,j)))
2999 tl_cff=-cff*cff*om_v(i,j)* &
3000 & 0.5_r8*(tl_dnew(i,j-1)+tl_dnew(i,j))
3001!^ vbar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3002!^
3003 tl_vbar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3004 & sources(ng)%Qbar(is)*tl_cff
3005#ifdef SOLVE3D
3006!^ DV_avg1(i,j)=SOURCES(ng)%Qbar(is)
3007!^
3008 tl_dv_avg1(i,j)=sources(ng)%tl_Qbar(is)
3009#endif
3010#if defined NESTING && !defined SOLVE3D
3011!^ DV_flux(i,j)=SOURCES(ng)%Qbar(is)
3012!^
3013 tl_dv_flux(i,j)=sources(ng)%tl_Qbar(is)
3014#endif
3015 END IF
3016 END IF
3017 END DO
3018 END IF
3019
3020#ifdef SOLVE3D
3021!
3022!-----------------------------------------------------------------------
3023! Finalize computation of barotropic mode averages.
3024!-----------------------------------------------------------------------
3025!
3026! This procedure starts with filling in boundary rows of total depths
3027! at the new time step, which is needed to be done only during the
3028! last barotropic time step, Normally, the computation of averages
3029! occurs at the beginning of the next predictor step because "DUon"
3030! and "DVom" are being computed anyway. Strictly speaking, the filling
3031! the boundaries are necessary only in the case of open boundaries,
3032! otherwise, the associated fluxes are all zeros.
3033!
3034 IF ((iif(ng).eq.nfast(ng)).and.(knew.lt.3)) THEN
3035 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3036 IF (domain(ng)%Western_Edge(tile)) THEN
3037 DO j=jstr-1,jendr
3038!^ Dnew(Istr-1,j)=h(Istr-1,j)+zeta_new(Istr-1,j)
3039!^
3040 tl_dnew(istr-1,j)=tl_h(istr-1,j)+tl_zeta_new(istr-1,j)
3041 END DO
3042 END IF
3043 END IF
3044 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3045 IF (domain(ng)%Eastern_Edge(tile)) THEN
3046 DO j=jstr-1,jendr
3047!^ Dnew(Iend+1,j)=h(Iend+1,j)+zeta_new(Iend+1,j)
3048!^
3049 tl_dnew(iend+1,j)=tl_h(iend+1,j)+tl_zeta_new(iend+1,j)
3050 END DO
3051 END IF
3052 END IF
3053 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3054 IF (domain(ng)%Southern_Edge(tile)) THEN
3055 DO i=istr-1,iendr
3056!^ Dnew(i,Jstr-1)=h(i,Jstr-1)+zeta_new(i,Jstr-1)
3057!^
3058 tl_dnew(i,jstr-1)=tl_h(i,jstr-1)+tl_zeta_new(i,jstr-1)
3059 END DO
3060 END IF
3061 END IF
3062 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3063 IF (domain(ng)%Northern_Edge(tile)) THEN
3064 DO i=istr-1,iendr
3065!^ Dnew(i,Jend+1)=h(i,Jend+1)+zeta_new(i,Jend+1)
3066!^
3067 tl_dnew(i,jend+1)=tl_h(i,jend+1)+tl_zeta_new(i,jend+1)
3068 END DO
3069 END IF
3070 END IF
3071!
3072! At the end of the last 2D time step replace the new free-surface
3073! zeta(:,:,knew) with it fast time-averaged value, Zt_avg1. Recall
3074! this is state variable is the one that communicates with the 3D
3075! kernel. Then, compute time-dependent depths.
3076!
3077 cff=weight(1,iif(ng),ng)
3078 cff1=0.5*cff
3079 DO j=jstrr,jendr
3080 DO i=istrr,iendr
3081!^ Zt_avg1(i,j)=Zt_avg1(i,j)+ &
3082!^ & cff*zeta(i,j,knew)
3083!^
3084 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+ &
3085 & cff*tl_zeta(i,j,knew)
3086 IF (i.ge.istr) THEN
3087!^ DU_avg1(i,j)=DU_avg1(i,j)+ &
3088!^ & cff1*on_u(i,j)* &
3089!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
3090!^
3091 tl_du_avg1(i,j)=tl_du_avg1(i,j)+ &
3092 & cff1*on_u(i,j)* &
3093 & ((dnew(i,j)+dnew(i-1,j))* &
3094 & tl_ubar(i,j,knew)+ &
3095 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
3096 & ubar(i,j,knew))
3097 END IF
3098 IF (j.ge.jstr) THEN
3099!^ DV_avg1(i,j)=DV_avg1(i,j)+ &
3100!^ & cff1*om_v(i,j)* &
3101!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
3102!^
3103 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+ &
3104 & cff1*om_v(i,j)* &
3105 & ((dnew(i,j)+dnew(i,j-1))* &
3106 & tl_vbar(i,j,knew)+ &
3107 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
3108 & vbar(i,j,knew))
3109 END IF
3110!^ zeta(i,j,knew)=Zt_avg1(i,j)
3111!^
3112 tl_zeta(i,j,knew)=tl_zt_avg1(i,j)
3113 END DO
3114 END DO
3115!^ CALL set_depth (ng, tile, iNLM)
3116!^
3117 CALL tl_set_depth (ng, tile, itlm)
3118
3119# ifdef NESTING
3120!
3121! After all fast time steps are completed, apply boundary conditions
3122! to time averaged fields.
3123!
3124! In nesting applications with refinement grids, we need to exchange
3125! the DU_avg2 and DV_avg2 fluxes boundary information for the case
3126! that a contact point is at a tile partition. Notice that in such
3127! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3128!
3129 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3130!^ CALL exchange_r2d_tile (ng, tile, &
3131!^ & LBi, UBi, LBj, UBj, &
3132!^ & Zt_avg1)
3133!^
3134 CALL exchange_r2d_tile (ng, tile, &
3135 & lbi, ubi, lbj, ubj, &
3136 & tl_zt_avg1)
3137!^ CALL exchange_u2d_tile (ng, tile, &
3138!^ & LBi, UBi, LBj, UBj, &
3139!^ & DU_avg1)
3140!^
3141 CALL exchange_u2d_tile (ng, tile, &
3142 & lbi, ubi, lbj, ubj, &
3143 & tl_du_avg1)
3144!^ CALL exchange_v2d_tile (ng, tile, &
3145!^ & LBi, UBi, LBj, UBj, &
3146!^ & DV_avg1)
3147!^
3148 CALL exchange_v2d_tile (ng, tile, &
3149 & lbi, ubi, lbj, ubj, &
3150 & tl_dv_avg1)
3151!^ CALL exchange_u2d_tile (ng, tile, &
3152!^ & LBi, UBi, LBj, UBj, &
3153!^ & DU_avg2)
3154!^
3155 CALL exchange_u2d_tile (ng, tile, &
3156 & lbi, ubi, lbj, ubj, &
3157 & tl_du_avg2)
3158!^ CALL exchange_v2d_tile (ng, tile, &
3159!^ & LBi, UBi, LBj, UBj, &
3160!^ & DV_avg2)
3161!^
3162 CALL exchange_v2d_tile (ng, tile, &
3163 & lbi, ubi, lbj, ubj, &
3164 & tl_dv_avg2)
3165 END IF
3166
3167# ifdef DISTRIBUTE
3168!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3169!^ & LBi, UBi, LBj, UBj, &
3170!^ & NghostPoints, &
3171!^ & EWperiodic(ng), NSperiodic(ng), &
3172!^ & Zt_avg1, DU_avg1, DV_avg1)
3173!^
3174 CALL mp_exchange2d (ng, tile, itlm, 3, &
3175 & lbi, ubi, lbj, ubj, &
3176 & nghostpoints, &
3177 & ewperiodic(ng), nsperiodic(ng), &
3178 & tl_zt_avg1, tl_du_avg1, tl_dv_avg1)
3179!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3180!^ & LBi, UBi, LBj, UBj, &
3181!^ & NghostPoints, &
3182!^ & EWperiodic(ng), NSperiodic(ng), &
3183!^ & DU_avg2, DV_avg2)
3184!^
3185 CALL mp_exchange2d (ng, tile, itlm, 2, &
3186 & lbi, ubi, lbj, ubj, &
3187 & nghostpoints, &
3188 & ewperiodic(ng), nsperiodic(ng), &
3189 & tl_du_avg2, tl_dv_avg2)
3190# endif
3191# endif
3192 END IF
3193#endif
3194#if defined NESTING && !defined SOLVE3D
3195!
3196! In nesting applications with refinement grids, we need to exchange
3197! the DU_flux and DV_flux fluxes boundary information for the case
3198! that a contact point is at a tile partition. Notice that in such
3199! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3200!
3201 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3202!^ CALL exchange_u2d_tile (ng, tile, &
3203!^ & LBi, UBi, LBj, UBj, &
3204!^ & DU_flux)
3205!^
3206 CALL exchange_u2d_tile (ng, tile, &
3207 & lbi, ubi, lbj, ubj, &
3208 & tl_du_flux)
3209!^ CALL exchange_v2d_tile (ng, tile, &
3210!^ & LBi, UBi, LBj, UBj, &
3211!^ & DV_flux)
3212!^
3213 CALL exchange_v2d_tile (ng, tile, &
3214 & lbi, ubi, lbj, ubj, &
3215 & tl_dv_flux)
3216 END IF
3217
3218# ifdef DISTRIBUTE
3219!
3220!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3221!^ & LBi, UBi, LBj, UBj, &
3222!^ & NghostPoints, &
3223!^ & EWperiodic(ng), NSperiodic(ng), &
3224!^ & DU_flux, DV_flux)
3225!^
3226 CALL mp_exchange2d (ng, tile, itlm, 2, &
3227 & lbi, ubi, lbj, ubj, &
3228 & nghostpoints, &
3229 & ewperiodic(ng), nsperiodic(ng), &
3230 & tl_du_flux, tl_dv_flux)
3231# endif
3232#endif
3233!
3234! Deallocate local new free-surface.
3235!
3236 deallocate ( tl_zeta_new )
3237
3238#ifdef WET_DRY_NOT_YET
3239!
3240!-----------------------------------------------------------------------
3241! Compute new wet/dry masks.
3242!-----------------------------------------------------------------------
3243!
3244!^ CALL wetdry_tile (ng, tile, &
3245!^ & LBi, UBi, LBj, UBj, &
3246!^ & IminS, ImaxS, JminS, JmaxS, &
3247# ifdef MASKING
3248!^ & pmask, rmask, umask, vmask, &
3249# endif
3250!^ & h, zeta(:,:,knew), &
3251# ifdef SOLVE3D
3252!^ & DU_avg1, DV_avg1, &
3253!^ & rmask_wet_avg, &
3254# endif
3255!^ & pmask_wet, pmask_full, &
3256!^ & rmask_wet, rmask_full, &
3257!^ & umask_wet, umask_full, &
3258!^ & vmask_wet, vmask_full)
3259!^
3260!^ HGA: Need the TLM code here.
3261!^
3262#endif
3263!
3264!-----------------------------------------------------------------------
3265! Exchange boundary information.
3266!-----------------------------------------------------------------------
3267!
3268 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3269!^ CALL exchange_r2d_tile (ng, tile, &
3270!^ & LBi, UBi, LBj, UBj, &
3271!^ & zeta(:,:,knew))
3272!^
3273 CALL exchange_r2d_tile (ng, tile, &
3274 & lbi, ubi, lbj, ubj, &
3275 & tl_zeta(:,:,knew))
3276!^ CALL exchange_u2d_tile (ng, tile, &
3277!^ & LBi, UBi, LBj, UBj, &
3278!^ & ubar(:,:,knew))
3279!^
3280 CALL exchange_u2d_tile (ng, tile, &
3281 & lbi, ubi, lbj, ubj, &
3282 & tl_ubar(:,:,knew))
3283!^ CALL exchange_v2d_tile (ng, tile, &
3284!^ & LBi, UBi, LBj, UBj, &
3285!^ & vbar(:,:,knew))
3286!^
3287 CALL exchange_v2d_tile (ng, tile, &
3288 & lbi, ubi, lbj, ubj, &
3289 & tl_vbar(:,:,knew))
3290 END IF
3291
3292#ifdef DISTRIBUTE
3293!
3294!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3295!^ & LBi, UBi, LBj, UBj, &
3296!^ & NghostPoints, &
3297!^ & EWperiodic(ng), NSperiodic(ng), &
3298!^ & zeta(:,:,knew), &
3299!^ & ubar(:,:,knew), &
3300!^ & vbar(:,:,knew))
3301!^
3302 CALL mp_exchange2d (ng, tile, itlm, 3, &
3303 & lbi, ubi, lbj, ubj, &
3304 & nghostpoints, &
3305 & ewperiodic(ng), nsperiodic(ng), &
3306 & tl_zeta(:,:,knew), &
3307 & tl_ubar(:,:,knew), &
3308 & tl_vbar(:,:,knew))
3309#endif
3310!
3311 RETURN

References mod_scalars::compositegrid, mod_param::domain, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_r2d_tile(), exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_scalars::inorth, mod_scalars::isouth, mod_param::itlm, mod_scalars::iwest, mod_scalars::luvsrc, mod_scalars::lwsrc, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, obc_volcons_mod::obc_flux_tile(), mod_scalars::predictor_2d_step, mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, tl_obc_volcons_mod::tl_obc_flux_tile(), tl_set_depth_mod::tl_set_depth(), tl_obc_volcons_mod::tl_set_duv_bc_tile(), tl_u2dbc_mod::tl_u2dbc_tile(), tl_v2dbc_mod::tl_v2dbc_tile(), mod_scalars::volcons, and mod_scalars::weight.

Here is the call graph for this function:

◆ tl_step2d_tile() [2/3]

subroutine tl_step2d_mod::tl_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) krhs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) omn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(in) tl_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_bustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_bvstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk,2), intent(inout) tl_ru,
real(r8), dimension(lbi:ubi,lbj:ubj,0:ubk,2), intent(inout) tl_rv,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(in) rzeta,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rzeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_zeta )
private

Definition at line 180 of file tl_step2d_LF_AM3.h.

257!***********************************************************************
258!
259! Imported variable declarations.
260!
261 integer, intent(in ) :: ng, tile
262 integer, intent(in ) :: LBi, UBi, LBj, UBj, UBk
263 integer, intent(in ) :: IminS, ImaxS, JminS, JmaxS
264 integer, intent(in ) :: krhs, kstp, knew
265#ifdef SOLVE3D
266 integer, intent(in ) :: nstp, nnew
267#endif
268!
269#ifdef ASSUMED_SHAPE
270# ifdef MASKING
271 real(r8), intent(in ) :: pmask(LBi:,LBj:)
272 real(r8), intent(in ) :: rmask(LBi:,LBj:)
273 real(r8), intent(in ) :: umask(LBi:,LBj:)
274 real(r8), intent(in ) :: vmask(LBi:,LBj:)
275# endif
276 real(r8), intent(in ) :: fomn(LBi:,LBj:)
277 real(r8), intent(in ) :: h(LBi:,LBj:)
278 real(r8), intent(in ) :: om_u(LBi:,LBj:)
279 real(r8), intent(in ) :: om_v(LBi:,LBj:)
280 real(r8), intent(in ) :: on_u(LBi:,LBj:)
281 real(r8), intent(in ) :: on_v(LBi:,LBj:)
282 real(r8), intent(in ) :: omn(LBi:,LBj:)
283 real(r8), intent(in ) :: pm(LBi:,LBj:)
284 real(r8), intent(in ) :: pn(LBi:,LBj:)
285# if defined CURVGRID && defined UV_ADV
286 real(r8), intent(in ) :: dndx(LBi:,LBj:)
287 real(r8), intent(in ) :: dmde(LBi:,LBj:)
288# endif
289# if defined UV_VIS2 || defined UV_VIS4
290 real(r8), intent(in ) :: pmon_r(LBi:,LBj:)
291 real(r8), intent(in ) :: pnom_r(LBi:,LBj:)
292 real(r8), intent(in ) :: pmon_p(LBi:,LBj:)
293 real(r8), intent(in ) :: pnom_p(LBi:,LBj:)
294 real(r8), intent(in ) :: om_r(LBi:,LBj:)
295 real(r8), intent(in ) :: on_r(LBi:,LBj:)
296 real(r8), intent(in ) :: om_p(LBi:,LBj:)
297 real(r8), intent(in ) :: on_p(LBi:,LBj:)
298# ifdef UV_VIS2
299 real(r8), intent(in ) :: visc2_p(LBi:,LBj:)
300 real(r8), intent(in ) :: visc2_r(LBi:,LBj:)
301# endif
302# ifdef UV_VIS4
303 real(r8), intent(in ) :: visc4_p(LBi:,LBj:)
304 real(r8), intent(in ) :: visc4_r(LBi:,LBj:)
305# endif
306# endif
307# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
308 real(r8), intent(in ) :: tl_bed_thick(LBi:,LBj:,:)
309# endif
310# ifdef WEC_MELLOR
311 real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:)
312 real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:)
313# endif
314# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
315 real(r8), intent(in ) :: eq_tide(LBi:,LBj:)
316 real(r8), intent(in ) :: tl_eq_tide(LBi:,LBj:)
317# endif
318 real(r8), intent(in ) :: rubar(LBi:,LBj:,:)
319 real(r8), intent(in ) :: rvbar(LBi:,LBj:,:)
320 real(r8), intent(in ) :: rzeta(LBi:,LBj:,:)
321 real(r8), intent(in ) :: ubar(LBi:,LBj:,:)
322 real(r8), intent(in ) :: vbar(LBi:,LBj:,:)
323 real(r8), intent(in ) :: zeta(LBi:,LBj:,:)
324# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
325 real(r8), intent(inout) :: tl_h(LBi:,LBj:)
326# else
327 real(r8), intent(in ) :: tl_h(LBi:,LBj:)
328# endif
329# ifndef SOLVE3D
330 real(r8), intent(in ) :: tl_bustr(LBi:,LBj:)
331 real(r8), intent(in ) :: tl_bvstr(LBi:,LBj:)
332# ifdef ATM_PRESS
333 real(r8), intent(in ) :: Pair(LBi:,LBj:)
334# endif
335# else
336# ifdef VAR_RHO_2D_NOT_YET
337 real(r8), intent(in ) :: rhoA(LBi:,LBj:)
338 real(r8), intent(in ) :: rhoS(LBi:,LBj:)
339 real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:)
340 real(r8), intent(in ) :: tl_rhoS(LBi:,LBj:)
341# endif
342 real(r8), intent(in ) :: Zt_avg1(LBi:,LBj:)
343
344 real(r8), intent(inout) :: tl_DU_avg1(LBi:,LBj:)
345 real(r8), intent(inout) :: tl_DU_avg2(LBi:,LBj:)
346 real(r8), intent(inout) :: tl_DV_avg1(LBi:,LBj:)
347 real(r8), intent(inout) :: tl_DV_avg2(LBi:,LBj:)
348 real(r8), intent(inout) :: tl_Zt_avg1(LBi:,LBj:)
349 real(r8), intent(inout) :: tl_rufrc(LBi:,LBj:)
350 real(r8), intent(inout) :: tl_rvfrc(LBi:,LBj:)
351 real(r8), intent(inout) :: tl_ru(LBi:,LBj:,0:,:)
352 real(r8), intent(inout) :: tl_rv(LBi:,LBj:,0:,:)
353# endif
354# ifdef WEC_MELLOR
355 real(r8), intent(inout) :: tl_rustr2d(LBi:,LBj:)
356 real(r8), intent(inout) :: tl_rvstr2d(LBi:,LBj:)
357 real(r8), intent(inout) :: tl_rulag2d(LBi:,LBj:)
358 real(r8), intent(inout) :: tl_rvlag2d(LBi:,LBj:)
359 real(r8), intent(inout) :: tl_ubar_stokes(LBi:,LBj:)
360 real(r8), intent(inout) :: tl_vbar_stokes(LBi:,LBj:)
361# endif
362# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
363 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
364 real(r8), intent(in ) :: tl_eq_tide(LBi:UBi,LBj:UBj)
365# endif
366# ifdef WET_DRY_NOT_YET
367 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
368 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
369 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
370 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
371
372 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
373 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
374 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
375 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
376# ifdef SOLVE3D
377 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
378# endif
379# endif
380# ifdef DIAGNOSTICS_UV
381!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
382!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
383!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
384!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
385# ifdef SOLVE3D
386!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
387!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
388!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
389!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
390# endif
391# endif
392 real(r8), intent(inout) :: tl_rubar(LBi:,LBj:,:)
393 real(r8), intent(inout) :: tl_rvbar(LBi:,LBj:,:)
394 real(r8), intent(inout) :: tl_rzeta(LBi:,LBj:,:)
395 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
396 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
397 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
398
399#else
400
401# ifdef MASKING
402 real(r8), intent(in ) :: pmask(LBi:UBi,LBj:UBj)
403 real(r8), intent(in ) :: rmask(LBi:UBi,LBj:UBj)
404 real(r8), intent(in ) :: umask(LBi:UBi,LBj:UBj)
405 real(r8), intent(in ) :: vmask(LBi:UBi,LBj:UBj)
406# endif
407 real(r8), intent(in ) :: fomn(LBi:UBi,LBj:UBj)
408 real(r8), intent(in ) :: h(LBi:UBi,LBj:UBj)
409 real(r8), intent(in ) :: om_u(LBi:UBi,LBj:UBj)
410 real(r8), intent(in ) :: om_v(LBi:UBi,LBj:UBj)
411 real(r8), intent(in ) :: on_u(LBi:UBi,LBj:UBj)
412 real(r8), intent(in ) :: on_v(LBi:UBi,LBj:UBj)
413 real(r8), intent(in ) :: omn(LBi:UBi,LBj:UBj)
414 real(r8), intent(in ) :: pm(LBi:UBi,LBj:UBj)
415 real(r8), intent(in ) :: pn(LBi:UBi,LBj:UBj)
416# if defined CURVGRID && defined UV_ADV
417 real(r8), intent(in ) :: dndx(LBi:UBi,LBj:UBj)
418 real(r8), intent(in ) :: dmde(LBi:UBi,LBj:UBj)
419# endif
420# if defined UV_VIS2 || defined UV_VIS4
421 real(r8), intent(in ) :: pmon_r(LBi:UBi,LBj:UBj)
422 real(r8), intent(in ) :: pnom_r(LBi:UBi,LBj:UBj)
423 real(r8), intent(in ) :: pmon_p(LBi:UBi,LBj:UBj)
424 real(r8), intent(in ) :: pnom_p(LBi:UBi,LBj:UBj)
425 real(r8), intent(in ) :: om_r(LBi:UBi,LBj:UBj)
426 real(r8), intent(in ) :: on_r(LBi:UBi,LBj:UBj)
427 real(r8), intent(in ) :: om_p(LBi:UBi,LBj:UBj)
428 real(r8), intent(in ) :: on_p(LBi:UBi,LBj:UBj)
429# ifdef UV_VIS2
430 real(r8), intent(in ) :: visc2_p(LBi:UBi,LBj:UBj)
431 real(r8), intent(in ) :: visc2_r(LBi:UBi,LBj:UBj)
432# endif
433# ifdef UV_VIS4
434 real(r8), intent(in ) :: visc4_p(LBi:UBi,LBj:UBj)
435 real(r8), intent(in ) :: visc4_r(LBi:UBi,LBj:UBj)
436# endif
437# endif
438# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
439 real(r8), intent(in ) :: tl_bed_thick(LBi:UBi,LBj:UBj,3)
440# endif
441# ifdef WEC_MELLOR
442 real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj)
443 real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj)
444# endif
445# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
446 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
447 real(r8), intent(in ) :: tl_eq_tide(LBi:UBi,LBj:UBj)
448# endif
449 real(r8), intent(in ) :: rubar(LBi:UBi,LBj:UBj,2)
450 real(r8), intent(in ) :: rvbar(LBi:UBi,LBj:UBj,2)
451 real(r8), intent(in ) :: rzeta(LBi:UBi,LBj:UBj,2)
452 real(r8), intent(in ) :: ubar(LBi:UBi,LBj:UBj,:)
453 real(r8), intent(in ) :: vbar(LBi:UBi,LBj:UBj,:)
454 real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:)
455# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
456 real(r8), intent(inout) :: tl_h(LBi:UBi,LBj:UBj)
457# else
458 real(r8), intent(in ) :: tl_h(LBi:UBi,LBj:UBj)
459# endif
460# ifndef SOLVE3D
461 real(r8), intent(in ) :: tl_bustr(LBi:UBi,LBj:UBj)
462 real(r8), intent(in ) :: tl_bvstr(LBi:UBi,LBj:UBj)
463# ifdef ATM_PRESS
464 real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj)
465# endif
466# else
467# ifdef VAR_RHO_2D_NOT_YET
468 real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj)
469 real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj)
470 real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj)
471 real(r8), intent(in ) :: tl_rhoS(LBi:UBi,LBj:UBj)
472# endif
473 real(r8), intent(in ) :: Zt_avg1(LBi:UBi,LBj:UBj)
474
475 real(r8), intent(inout) :: tl_DU_avg1(LBi:UBi,LBj:UBj)
476 real(r8), intent(inout) :: tl_DU_avg2(LBi:UBi,LBj:UBj)
477 real(r8), intent(inout) :: tl_DV_avg1(LBi:UBi,LBj:UBj)
478 real(r8), intent(inout) :: tl_DV_avg2(LBi:UBi,LBj:UBj)
479 real(r8), intent(inout) :: tl_Zt_avg1(LBi:UBi,LBj:UBj)
480 real(r8), intent(inout) :: tl_rufrc(LBi:UBi,LBj:UBj)
481 real(r8), intent(inout) :: tl_rvfrc(LBi:UBi,LBj:UBj)
482 real(r8), intent(inout) :: tl_ru(LBi:UBi,LBj:UBj,0:UBk,2)
483 real(r8), intent(inout) :: tl_rv(LBi:UBi,LBj:UBj,0:UBk,2)
484# endif
485# ifdef WEC_MELLOR
486 real(r8), intent(inout) :: tl_rustr2d(LBi:UBi,LBj:UBj)
487 real(r8), intent(inout) :: tl_rvstr2d(LBi:UBi,LBj:UBj)
488 real(r8), intent(inout) :: tl_rulag2d(LBi:UBi,LBj:UBj)
489 real(r8), intent(inout) :: tl_rvlag2d(LBi:UBi,LBj:UBj)
490 real(r8), intent(inout) :: tl_ubar_stokes(LBi:UBi,LBj:UBj)
491 real(r8), intent(inout) :: tl_vbar_stokes(LBi:UBi,LBj:UBj)
492# endif
493# ifdef WET_DRY_NOT_YET
494 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
495 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
496 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
497 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
498
499 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
500 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
501 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
502 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
503# ifdef SOLVE3D
504 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
505# endif
506# endif
507# ifdef DIAGNOSTICS_UV
508!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
509!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
510!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
511!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
512# ifdef SOLVE3D
513!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
514!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
515!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
516!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
517# endif
518# endif
519 real(r8), intent(inout) :: tl_rubar(LBi:UBi,LBj:UBj,2)
520 real(r8), intent(inout) :: tl_rvbar(LBi:UBi,LBj:UBj,2)
521 real(r8), intent(inout) :: tl_rzeta(LBi:UBi,LBj:UBj,2)
522 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
523 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
524 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
525#endif
526!
527! Local variable declarations.
528!
529 logical :: CORRECTOR_2D_STEP
530!
531 integer :: i, is, j, ptsk
532#ifdef DIAGNOSTICS_UV
533!! integer :: idiag
534#endif
535!
536 real(r8) :: cff, cff1, cff2, cff3, cff4, cff5, cff6, cff7
537 real(r8) :: fac, fac1, fac2, fac3
538 real(r8) :: tl_cff, tl_cff1, tl_cff2, tl_cff3, tl_cff4
539 real(r8) :: tl_fac, tl_fac1
540!
541 real(r8), parameter :: IniVal = 0.0_r8
542!
543 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
544 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
545 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
546 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
547 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
548 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
549 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
550#ifdef WEC_MELLOR
551 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
552 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
553#endif
554#ifdef UV_VIS4
555 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: LapU
556 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: LapV
557#endif
558 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
559 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
560 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
561 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
562 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
563 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzeta
564 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzeta2
565#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
566 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: gzetaSA
567#endif
568 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_ubar
569 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_vbar
570 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rhs_zeta
571 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
572 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
573#ifdef WET_DRY_NOT_YET
574 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
575#endif
576#ifdef DIAGNOSTICS_UV
577!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
578!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
579!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaU2rhs
580!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaV2rhs
581#endif
582
583 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dgrad
584 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dnew
585 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs
586 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs_p
587 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dstp
588 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUon
589 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVom
590#ifdef WEC_MELLOR
591 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUSon
592 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVSom
593#endif
594#ifdef UV_VIS4
595 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_LapU
596 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_LapV
597#endif
598 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFe
599 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFx
600 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFe
601 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFx
602 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad
603 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_gzeta
604 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_gzeta2
605#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
606 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_gzetaSA
607#endif
608 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rhs_ubar
609 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rhs_vbar
610 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rhs_zeta
611 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_zeta_new
612 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_zwrk
613#ifdef WET_DRY_NOT_YET
614 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_wetdry
615#endif
616
617#include "set_bounds.h"
618!
619 ptsk=3-kstp
620 corrector_2d_step=.not.predictor_2d_step(ng)
621#ifdef DEBUG
622 IF (master) THEN
623 WRITE (20,20) iic(ng), predictor_2d_step(ng), &
624 & kstp, krhs, knew, ptsk
625 20 FORMAT (' iic = ',i5.5,' predictor = ',l1,' kstp = ',i1, &
626 & ' krhs = ',i1,' knew = ',i1,' ptsk = ',i1)
627 END IF
628#endif
629#ifdef INITIALIZE_AUTOMATIC
630!
631!-----------------------------------------------------------------------
632! Initialize local automatic arrays to zero to facilitate debugging
633! in TotalView when comparing "checksum" with other solutions.
634!-----------------------------------------------------------------------
635!
636 DO j=jmins,jmaxs
637 DO i=imins,imaxs
638 dgrad(i,j)=inival
639 dnew(i,j)=inival
640 drhs(i,j)=inival
641 drhs_p(i,j)=inival
642 dstp(i,j)=inival
643 duon(i,j)=inival
644 dvom(i,j)=inival
645# ifdef WEC_MELLOR
646 duson(i,j)=inival
647 dvsom(i,j)=inival
648# endif
649# ifdef UV_VIS4
650 lapu(i,j)=inival
651 lapv(i,j)=inival
652# endif
653 ufe(i,j)=inival
654 ufx(i,j)=inival
655 vfe(i,j)=inival
656 vfx(i,j)=inival
657 grad(i,j)=inival
658 gzeta(i,j)=inival
659 gzeta2(i,j)=inival
660# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
661 gzetasa(i,j)=inival
662# endif
663 rhs_ubar(i,j)=inival
664 rhs_vbar(i,j)=inival
665 rhs_zeta(i,j)=inival
666 zeta_new(i,j)=inival
667 zwrk(i,j)=inival
668!
669 tl_dgrad(i,j)=inival
670 tl_dnew(i,j)=inival
671 tl_drhs(i,j)=inival
672 tl_drhs_p(i,j)=inival
673 tl_dstp(i,j)=inival
674 tl_duon(i,j)=inival
675 tl_dvom(i,j)=inival
676# ifdef WEC_MELLOR
677 tl_duson(i,j)=inival
678 tl_dvsom(i,j)=inival
679# endif
680# ifdef UV_VIS4
681 tl_lapu(i,j)=inival
682 tl_lapv(i,j)=inival
683# endif
684 tl_ufe(i,j)=inival
685 tl_ufx(i,j)=inival
686 tl_vfe(i,j)=inival
687 tl_vfx(i,j)=inival
688 tl_grad(i,j)=inival
689 tl_gzeta(i,j)=inival
690 tl_gzeta2(i,j)=inival
691# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
692 tl_gzetasa(i,j)=inival
693# endif
694 tl_rhs_ubar(i,j)=inival
695 tl_rhs_vbar(i,j)=inival
696 tl_rhs_zeta(i,j)=inival
697 tl_zeta_new(i,j)=inival
698 tl_zwrk(i,j)=inival
699 END DO
700 END DO
701#endif
702!
703!-----------------------------------------------------------------------
704! Compute total depth (m) and vertically integrated mass fluxes.
705!-----------------------------------------------------------------------
706!
707#if defined DISTRIBUTE && !defined NESTING
708
709! In distributed-memory, the I- and J-ranges are different and a
710! special exchange is done to avoid having three ghost points for
711! high order numerical stencils. Notice that a private array is
712! passed below to the exchange routine. It also applies periodic
713! boundary conditions, if appropriate and no partitions in I- or
714! J-directions.
715!
716 DO j=jstrv-2,jendp2
717 DO i=istru-2,iendp2
718 dnew(i,j)=zeta(i,j,knew)+h(i,j)
719 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
720 tl_drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
721 END DO
722 END DO
723 DO j=jstrv-2,jendp2
724 DO i=istru-1,iendp2
725 cff=0.5_r8*on_u(i,j)
726 cff1=cff*(drhs(i,j)+drhs(i-1,j))
727 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i-1,j))
728 duon(i,j)=ubar(i,j,krhs)*cff1
729 tl_duon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
730 & ubar(i,j,krhs)*tl_cff1
731# ifdef WEC_MELLOR
732 duson(i,j)=ubar_stokes(i,j)*cff1
733 tl_duson(i,j)=tl_ubar_stokes(i,j)*cff1+ &
734 & ubar_stokes(i,j)*tl_cff1
735 duon(i,j)=duon(i,j)+duson(i,j)
736 tl_duon(i,j)=tl_duon(i,j)+tl_duson(i,j)
737# endif
738 END DO
739 END DO
740 DO j=jstrv-1,jendp2
741 DO i=istru-2,iendp2
742 cff=0.5_r8*om_v(i,j)
743 cff1=cff*(drhs(i,j)+drhs(i,j-1))
744 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i,j-1))
745 dvom(i,j)=vbar(i,j,krhs)*cff1
746 tl_dvom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
747 & vbar(i,j,krhs)*tl_cff1
748# ifdef WEC_MELLOR
749 dvsom(i,j)=vbar_stokes(i,j)*cff1
750 tl_dvsom(i,j)=tl_vbar_stokes(i,j)*cff1+ &
751 & vbar_stokes(i,j)*tl_cff1
752 dvom(i,j)=dvom(i,j)+dvsom(i,j)
753 tl_dvom(i,j)=tl_dvom(i,j)+tl_dvsom(i,j)
754# endif
755 END DO
756 END DO
757
758#else
759
760 DO j=jstrvm2-1,jendp2
761 DO i=istrum2-1,iendp2
762 dnew(i,j)=zeta(i,j,knew)+h(i,j)
763 drhs(i,j)=zeta(i,j,krhs)+h(i,j)
764 tl_drhs(i,j)=tl_zeta(i,j,krhs)+tl_h(i,j)
765 END DO
766 END DO
767 DO j=jstrvm2-1,jendp2
768 DO i=istrum2,iendp2
769 cff=0.5_r8*on_u(i,j)
770 cff1=cff*(drhs(i,j)+drhs(i-1,j))
771 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i-1,j))
772 duon(i,j)=ubar(i,j,krhs)*cff1
773 tl_duon(i,j)=tl_ubar(i,j,krhs)*cff1+ &
774 & ubar(i,j,krhs)*tl_cff1
775# ifdef WEC_MELLOR
776 duson(i,j)=ubar_stokes(i,j)*cff1
777 tl_duson(i,j)=tl_ubar_stokes(i,j)*cff1+ &
778 & ubar_stokes(i,j)*tl_cff1
779 duon(i,j)=duon(i,j)+duson(i,j)
780 tl_duon(i,j)=tl_duon(i,j)+tl_duson(i,j)
781# endif
782 END DO
783 END DO
784 DO j=jstrvm2,jendp2
785 DO i=istrum2-1,iendp2
786 cff=0.5_r8*om_v(i,j)
787 cff1=cff*(drhs(i,j)+drhs(i,j-1))
788 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i,j-1))
789 dvom(i,j)=vbar(i,j,krhs)*cff1
790 tl_dvom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
791 & vbar(i,j,krhs)*tl_cff1
792# ifdef WEC_MELLOR
793 dvsom(i,j)=vbar_stokes(i,j)*cff1
794 tl_dvsom(i,j)=tl_vbar_stokes(i,j)*cff1+ &
795 & vbar_stokes(i,j)*tl_cff1
796 dvom(i,j)=dvom(i,j)+dvsom(i,j)
797 tl_dvom(i,j)=tl_dvom(i,j)+tl_dvsom(i,j)
798# endif
799 END DO
800 END DO
801#endif
802#ifdef DISTRIBUTE
803!
804 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
805 CALL exchange_u2d_tile (ng, tile, &
806 & imins, imaxs, jmins, jmaxs, &
807 & duon)
808 CALL exchange_u2d_tile (ng, tile, &
809 & imins, imaxs, jmins, jmaxs, &
810 & tl_duon)
811 CALL exchange_v2d_tile (ng, tile, &
812 & imins, imaxs, jmins, jmaxs, &
813 & dvom)
814 CALL exchange_v2d_tile (ng, tile, &
815 & imins, imaxs, jmins, jmaxs, &
816 & tl_dvom)
817 END IF
818
819 CALL mp_exchange2d (ng, tile, itlm, 2, &
820 & imins, imaxs, jmins, jmaxs, &
821 & nghostpoints, &
822 & ewperiodic(ng), nsperiodic(ng), &
823 & duon, dvom)
824 CALL mp_exchange2d (ng, tile, itlm, 2, &
825 & imins, imaxs, jmins, jmaxs, &
826 & nghostpoints, &
827 & ewperiodic(ng), nsperiodic(ng), &
828 & tl_duon, tl_dvom)
829#endif
830#if !defined FORWARD_RHS
831!
832! Initialize right-hand-side terms.
833!
834 DO j=jstr,jend
835 DO i=istr,iend
836 rhs_ubar(i,j)=0.0_r8
837 rhs_vbar(i,j)=0.0_r8
838 END DO
839 END DO
840#endif
841!
842! Compute integral mass flux across open boundaries and adjust
843! for volume conservation. Compute BASIC STATE value.
844! This needs to be computed here instead of below.
845!
846 IF (any(tl_volcons(:,ng))) THEN
847 CALL obc_flux_tile (ng, tile, &
848 & lbi, ubi, lbj, ubj, &
849 & imins, imaxs, jmins, jmaxs, &
850 & knew, &
851#ifdef MASKING
852 & umask, vmask, &
853#endif
854 & h, om_v, on_u, &
855 & ubar, vbar, zeta)
856!
857! Set vertically integrated mass fluxes DUon and DVom along the open
858! boundaries in such a way that the integral volume is conserved.
859!
860 CALL set_duv_bc_tile (ng, tile, &
861 & lbi, ubi, lbj, ubj, &
862 & imins, imaxs, jmins, jmaxs, &
863 & krhs, &
864#ifdef MASKING
865 & umask, vmask, &
866#endif
867 & om_v, on_u, &
868 & ubar, vbar, &
869 & drhs, duon, dvom)
870 CALL tl_set_duv_bc_tile (ng, tile, &
871 & lbi, ubi, lbj, ubj, &
872 & imins, imaxs, jmins, jmaxs, &
873 & krhs, &
874#ifdef MASKING
875 & umask, vmask, &
876#endif
877 & om_v, on_u, ubar, vbar, &
878 & tl_ubar, tl_vbar, &
879 & drhs, duon, dvom, &
880 & tl_drhs, tl_duon, tl_dvom)
881 END IF
882#ifdef SOLVE3D
883!
884!-----------------------------------------------------------------------
885! Compute time averaged fields over all short time-steps.
886!-----------------------------------------------------------------------
887!
888 IF (predictor_2d_step(ng)) THEN
889 IF (first_2d_step) THEN
890!
891! Reset arrays for 2D fields averaged within the short time-steps.
892!
893 cff2=(-1.0_r8/12.0_r8)*weight(2,iif(ng)+1,ng)
894 DO j=jstrr,jendr
895 DO i=istrr,iendr
896!^ Zt_avg1(i,j)=0.0_r8
897!^
898 tl_zt_avg1(i,j)=0.0_r8
899 END DO
900 DO i=istr,iendr
901!^ DU_avg1(i,j)=0.0_r8
902!^
903 tl_du_avg1(i,j)=0.0_r8
904!^ DU_avg2(i,j)=cff2*DUon(i,j)
905!^
906 tl_du_avg2(i,j)=cff2*tl_duon(i,j)
907 END DO
908 END DO
909 DO j=jstr,jendr
910 DO i=istrr,iendr
911!^ DV_avg1(i,j)=0.0_r8
912!^
913 tl_dv_avg1(i,j)=0.0_r8
914!^ DV_avg2(i,j)=cff2*DVom(i,j)
915!^
916 tl_dv_avg2(i,j)=cff2*tl_dvom(i,j)
917 END DO
918 END DO
919 ELSE
920!
921! Accumulate field averages of previous time-step after they are
922! computed in the previous corrector step, updated their boundaries,
923! and synchronized.
924!
925 cff1=weight(1,iif(ng)-1,ng)
926 cff2=(8.0_r8/12.0_r8)*weight(2,iif(ng) ,ng)- &
927 & (1.0_r8/12.0_r8)*weight(2,iif(ng)+1,ng)
928 DO j=jstrr,jendr
929 DO i=istrr,iendr
930!^ Zt_avg1(i,j)=Zt_avg1(i,j)+cff1*zeta(i,j,krhs)
931!^
932 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+cff1*tl_zeta(i,j,krhs)
933 END DO
934 DO i=istr,iendr
935!^ DU_avg1(i,j)=DU_avg1(i,j)+cff1*DUon(i,j)
936!^
937 tl_du_avg1(i,j)=tl_du_avg1(i,j)+cff1*tl_duon(i,j)
938# ifdef WEC_MELLOR
939!^ DU_avg1(i,j)=DU_avg1(i,j)-cff1*DUSon(i,j)
940!^
941 tl_du_avg1(i,j)=tl_du_avg1(i,j)-cff1*tl_duson(i,j)
942# endif
943!^ DU_avg2(i,j)=DU_avg2(i,j)+cff2*DUon(i,j)
944!^
945 tl_du_avg2(i,j)=tl_du_avg2(i,j)+cff2*tl_duon(i,j)
946 END DO
947 END DO
948 DO j=jstr,jendr
949 DO i=istrr,iendr
950!^ DV_avg1(i,j)=DV_avg1(i,j)+cff1*DVom(i,j)
951!^
952 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+cff1*tl_dvom(i,j)
953# ifdef WEC_MELLOR
954!^ DV_avg1(i,j)=DV_avg1(i,j)-cff1*DVSom(i,j)
955!^
956 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)-cff1*tl_dvsom(i,j)
957# endif
958!^ DV_avg2(i,j)=DV_avg2(i,j)+cff2*DVom(i,j)
959!^
960 tl_dv_avg2(i,j)=tl_dv_avg2(i,j)+cff2*tl_dvom(i,j)
961 END DO
962 END DO
963 END IF
964 ELSE
965 IF (first_2d_step) THEN
966 cff2=weight(2,iif(ng),ng)
967 ELSE
968 cff2=(5.0_r8/12.0_r8)*weight(2,iif(ng),ng)
969 END IF
970 DO j=jstrr,jendr
971 DO i=istr,iendr
972!^ DU_avg2(i,j)=DU_avg2(i,j)+cff2*DUon(i,j)
973!^
974 tl_du_avg2(i,j)=tl_du_avg2(i,j)+cff2*tl_duon(i,j)
975 END DO
976 END DO
977 DO j=jstr,jendr
978 DO i=istrr,iendr
979!^ DV_avg2(i,j)=DV_avg2(i,j)+cff2*DVom(i,j)
980!^
981 tl_dv_avg2(i,j)=tl_dv_avg2(i,j)+cff2*tl_dvom(i,j)
982 END DO
983 END DO
984 END IF
985!
986! After all fast time steps are completed, apply boundary conditions
987! to time averaged fields.
988# ifdef NESTING
989! In nesting applications with refinement grids, we need to exchange
990! the DU_avg2 and DV_avg2 fluxes boundary information for the case
991! that a contact point is at a tile partition. Notice that in such
992! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
993# endif
994!
995 IF ((iif(ng).eq.(nfast(ng)+1)).and.predictor_2d_step(ng)) THEN
996 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
997!^ CALL exchange_r2d_tile (ng, tile, &
998!^ & LBi, UBi, LBj, UBj, &
999!^ & Zt_avg1)
1000!^
1001 CALL exchange_r2d_tile (ng, tile, &
1002 & lbi, ubi, lbj, ubj, &
1003 & tl_zt_avg1)
1004!^ CALL exchange_u2d_tile (ng, tile, &
1005!^ & LBi, UBi, LBj, UBj, &
1006!^ & DU_avg1)
1007!^
1008 CALL exchange_u2d_tile (ng, tile, &
1009 & lbi, ubi, lbj, ubj, &
1010 & tl_du_avg1)
1011!^ CALL exchange_v2d_tile (ng, tile, &
1012!^ & LBi, UBi, LBj, UBj, &
1013!^ & DV_avg1)
1014!^
1015 CALL exchange_v2d_tile (ng, tile, &
1016 & lbi, ubi, lbj, ubj, &
1017 & tl_dv_avg1)
1018# ifdef NESTING
1019!^ CALL exchange_u2d_tile (ng, tile, &
1020!^ & LBi, UBi, LBj, UBj, &
1021!^ & DU_avg2)
1022!^
1023 CALL exchange_u2d_tile (ng, tile, &
1024 & lbi, ubi, lbj, ubj, &
1025 & tl_du_avg2)
1026!^ CALL exchange_v2d_tile (ng, tile, &
1027!^ & LBi, UBi, LBj, UBj, &
1028!^ & DV_avg2)
1029!^
1030 CALL exchange_v2d_tile (ng, tile, &
1031 & lbi, ubi, lbj, ubj, &
1032 & tl_dv_avg2)
1033# endif
1034 END IF
1035
1036# ifdef DISTRIBUTE
1037!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
1038!^ & LBi, UBi, LBj, UBj, &
1039!^ & NghostPoints, &
1040!^ & EWperiodic(ng), NSperiodic(ng), &
1041!^ & Zt_avg1, DU_avg1, DV_avg1)
1042!^
1043 CALL mp_exchange2d (ng, tile, itlm, 3, &
1044 & lbi, ubi, lbj, ubj, &
1045 & nghostpoints, &
1046 & ewperiodic(ng), nsperiodic(ng), &
1047 & tl_zt_avg1, tl_du_avg1, tl_dv_avg1)
1048# ifdef NESTING
1049!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
1050!^ & LBi, UBi, LBj, UBj, &
1051!^ & NghostPoints, &
1052!^ & EWperiodic(ng), NSperiodic(ng), &
1053!^ & DU_avg2, DV_avg2)
1054!^
1055 CALL mp_exchange2d (ng, tile, itlm, 2, &
1056 & lbi, ubi, lbj, ubj, &
1057 & nghostpoints, &
1058 & ewperiodic(ng), nsperiodic(ng), &
1059 & tl_du_avg2, tl_dv_avg2)
1060# endif
1061# endif
1062 END IF
1063#endif
1064#ifdef WET_DRY_NOT_YET
1065!
1066!-----------------------------------------------------------------------
1067! Compute new wet/dry masks.
1068!-----------------------------------------------------------------------
1069!
1070!^ CALL wetdry_tile (ng, tile, &
1071!^ & LBi, UBi, LBj, UBj, &
1072!^ & IminS, ImaxS, JminS, JmaxS, &
1073# ifdef MASKING
1074!^ & pmask, rmask, umask, vmask, &
1075# endif
1076!^ & h, zeta(:,:,kstp), &
1077# ifdef SOLVE3D
1078!^ & DU_avg1, DV_avg1, &
1079!^ & rmask_wet_avg, &
1080# endif
1081!^ & pmask_wet, pmask_full, &
1082!^ & rmask_wet, rmask_full, &
1083!^ & umask_wet, umask_full, &
1084!^ & vmask_wet, vmask_full)
1085!^
1086!^ HGA: Need the TLM code here.
1087!^
1088#endif
1089!
1090! Do not perform the actual time stepping during the auxiliary
1091! (nfast(ng)+1) time step.
1092!
1093 IF (iif(ng).gt.nfast(ng)) RETURN
1094!
1095!=======================================================================
1096! Time step free-surface equation.
1097!=======================================================================
1098!
1099! During the first time-step, the predictor step is Forward-Euler
1100! and the corrector step is Backward-Euler. Otherwise, the predictor
1101! step is Leap-frog and the corrector step is Adams-Moulton.
1102!
1103#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1104 fac=1000.0_r8/rho0
1105#endif
1106#if defined STOCHASTIC_OPT && !defined STOCH_OPT_WHITE && \
1107 !defined SOLVE3D
1108 IF (first_2d_step.and.soinitial(ng)) THEN
1109#else
1110 IF (first_2d_step) THEN
1111#endif
1112 cff1=dtfast(ng)
1113 DO j=jstrv-1,jend
1114 DO i=istru-1,iend
1115!^ rhs_zeta(i,j)=(DUon(i,j)-DUon(i+1,j))+ &
1116!^ & (DVom(i,j)-DVom(i,j+1))
1117!^
1118 tl_rhs_zeta(i,j)=(tl_duon(i,j)-tl_duon(i+1,j))+ &
1119 & (tl_dvom(i,j)-tl_dvom(i,j+1))
1120!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1121!^ & pm(i,j)*pn(i,j)*cff1*rhs_zeta(i,j)
1122!^
1123!^ use background instead
1124 zeta_new(i,j)=zeta(i,j,knew)
1125 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1126 & pm(i,j)*pn(i,j)*cff1*tl_rhs_zeta(i,j)
1127#ifdef MASKING
1128 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1129 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1130#endif
1131!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
1132!^
1133 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
1134!
1135 zwrk(i,j)=0.5_r8*(zeta(i,j,kstp)+zeta_new(i,j))
1136 tl_zwrk(i,j)=0.5_r8*(tl_zeta(i,j,kstp)+tl_zeta_new(i,j))
1137#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1138 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
1139 tl_gzeta(i,j)=(fac+rhos(i,j))*tl_zwrk(i,j)+ &
1140 & tl_rhos(i,j)*zwrk(i,j)
1141 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
1142 tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
1143 & gzeta(i,j)*tl_zwrk(i,j)
1144 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1145 tl_gzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1146 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
1147#else
1148 gzeta(i,j)=zwrk(i,j)
1149 tl_gzeta(i,j)=tl_zwrk(i,j)
1150 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1151 tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
1152#endif
1153 END DO
1154 END DO
1155 ELSE IF (predictor_2d_step(ng)) THEN
1156 cff1=2.0_r8*dtfast(ng)
1157 cff4=4.0_r8/25.0_r8
1158 cff5=1.0_r8-2.0_r8*cff4
1159 DO j=jstrv-1,jend
1160 DO i=istru-1,iend
1161!^ rhs_zeta(i,j)=(DUon(i,j)-DUon(i+1,j))+ &
1162!^ & (DVom(i,j)-DVom(i,j+1))
1163!^
1164 tl_rhs_zeta(i,j)=(tl_duon(i,j)-tl_duon(i+1,j))+ &
1165 & (tl_dvom(i,j)-tl_dvom(i,j+1))
1166!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1167!^ & pm(i,j)*pn(i,j)*cff1*rhs_zeta(i,j)
1168!^
1169!^ use background instead
1170 zeta_new(i,j)=zeta(i,j,knew)
1171 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1172 & pm(i,j)*pn(i,j)*cff1*tl_rhs_zeta(i,j)
1173#ifdef MASKING
1174 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1175 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1176#endif
1177!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
1178!^
1179 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
1180!
1181 zwrk(i,j)=cff5*zeta(i,j,krhs)+ &
1182 & cff4*(zeta(i,j,kstp)+zeta_new(i,j))
1183 tl_zwrk(i,j)=cff5*tl_zeta(i,j,krhs)+ &
1184 & cff4*(tl_zeta(i,j,kstp)+tl_zeta_new(i,j))
1185#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1186 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
1187 tl_gzeta(i,j)=(fac+rhos(i,j))*tl_zwrk(i,j)+ &
1188 & tl_rhos(i,j)*zwrk(i,j)
1189 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
1190 tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
1191 & gzeta(i,j)*tl_zwrk(i,j)
1192 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1193 tl_gzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1194 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
1195#else
1196 gzeta(i,j)=zwrk(i,j)
1197 tl_gzeta(i,j)=tl_zwrk(i,j)
1198 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1199 tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
1200#endif
1201 END DO
1202 END DO
1203 ELSE IF (corrector_2d_step) THEN
1204 cff1=dtfast(ng)*5.0_r8/12.0_r8
1205 cff2=dtfast(ng)*8.0_r8/12.0_r8
1206 cff3=dtfast(ng)*1.0_r8/12.0_r8
1207 cff4=2.0_r8/5.0_r8
1208 cff5=1.0_r8-cff4
1209 DO j=jstrv-1,jend
1210 DO i=istru-1,iend
1211!^ cff=cff1*((DUon(i,j)-DUon(i+1,j))+ &
1212!^ & (DVom(i,j)-DVom(i,j+1)))
1213!^
1214 tl_cff=cff1*((tl_duon(i,j)-tl_duon(i+1,j))+ &
1215 & (tl_dvom(i,j)-tl_dvom(i,j+1)))
1216!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1217!^ & pm(i,j)*pn(i,j)*(cff+ &
1218!^ & cff2*rzeta(i,j,kstp)- &
1219!^ & cff3*rzeta(i,j,ptsk))
1220!^
1221!^ use background instead
1222 zeta_new(i,j)=zeta(i,j,knew)
1223 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1224 & pm(i,j)*pn(i,j)*(tl_cff+ &
1225 & cff2*tl_rzeta(i,j,kstp)- &
1226 & cff3*tl_rzeta(i,j,ptsk))
1227#ifdef MASKING
1228 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1229 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1230#endif
1231!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
1232!^
1233 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
1234!
1235 zwrk(i,j)=cff5*zeta_new(i,j)+cff4*zeta(i,j,krhs)
1236 tl_zwrk(i,j)=cff5*tl_zeta_new(i,j)+cff4*tl_zeta(i,j,krhs)
1237#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1238 gzeta(i,j)=(fac+rhos(i,j))*zwrk(i,j)
1239 tl_gzeta(i,j)=(fac+rhos(i,j))*tl_zwrk(i,j)+ &
1240 & tl_rhos(i,j)*zwrk(i,j)
1241 gzeta2(i,j)=gzeta(i,j)*zwrk(i,j)
1242 tl_gzeta2(i,j)=tl_gzeta(i,j)*zwrk(i,j)+ &
1243 & gzeta(i,j)*tl_zwrk(i,j)
1244 gzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1245 tl_gzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1246 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
1247#else
1248 gzeta(i,j)=zwrk(i,j)
1249 tl_gzeta(i,j)=tl_zwrk(i,j)
1250 gzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1251 tl_gzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
1252#endif
1253 END DO
1254 END DO
1255 END IF
1256!
1257! Load new free-surface values into shared array at both predictor
1258! and corrector steps.
1259#ifdef WET_DRY_NOT_YET
1260! Modify new free-surface to Ensure that depth is > Dcrit for masked
1261! cells.
1262#endif
1263!
1264 DO j=jstr,jend
1265 DO i=istr,iend
1266!^ zeta(i,j,knew)=zeta_new(i,j)
1267!^
1268 tl_zeta(i,j,knew)=tl_zeta_new(i,j)
1269#if defined WET_DRY_NOT_YET && defined MASKING
1270!^ zeta(i,j,knew)=zeta(i,j,knew)+ &
1271!^ & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
1272!^
1273 tl_zeta(i,j,knew)=tl_zeta(i,j,knew)- &
1274 & tl_h(i,j)*(1.0_r8-rmask(i,j))
1275#endif
1276 END DO
1277 END DO
1278!
1279! If predictor step, load right-side-term into shared array.
1280!
1281 IF (predictor_2d_step(ng)) THEN
1282 DO j=jstr,jend
1283 DO i=istr,iend
1284!^ rzeta(i,j,krhs)=rhs_zeta(i,j)
1285!^
1286 tl_rzeta(i,j,krhs)=tl_rhs_zeta(i,j)
1287 END DO
1288 END DO
1289
1290 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1291!^ CALL exchange_r2d_tile (ng, tile, &
1292!^ & LBi, UBi, LBj, UBj, &
1293!^ & rzeta(:,:,krhs))
1294!^
1295 CALL exchange_r2d_tile (ng, tile, &
1296 & lbi, ubi, lbj, ubj, &
1297 & tl_rzeta(:,:,krhs))
1298 END IF
1299
1300#ifdef DISTRIBUTE
1301!^ CALL mp_exchange2d (ng, tile, iNLM, 1, &
1302!^ & LBi, UBi, LBj, UBj, &
1303!^ & NghostPoints, &
1304!^ & EWperiodic(ng), NSperiodic(ng), &
1305!^ & rzeta(:,:,krhs))
1306!^
1307 CALL mp_exchange2d (ng, tile, itlm, 1, &
1308 & lbi, ubi, lbj, ubj, &
1309 & nghostpoints, &
1310 & ewperiodic(ng), nsperiodic(ng), &
1311 & tl_rzeta(:,:,krhs))
1312#endif
1313 END IF
1314!
1315! Apply mass point sources (volume vertical influx), if any.
1316!
1317! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
1318!
1319 IF (lwsrc(ng)) THEN
1320 DO is=1,nsrc(ng)
1321 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
1322 i=sources(ng)%Isrc(is)
1323 j=sources(ng)%Jsrc(is)
1324 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1325 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1326!^ zeta(i,j,knew)=zeta(i,j,knew)+ &
1327!^ & SOURCES(ng)%Qbar(is)* &
1328!^ & pm(i,j)*pn(i,j)*dtfast(ng)
1329!^
1330!! tl_zeta(i,j,knew)=tl_zeta(i,j,knew)+0.0_r8
1331 END IF
1332 END IF
1333 END DO
1334 END IF
1335
1336#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1337!
1338! Scale the bed change with the fast time stepping. The half is
1339! becasue we do predictor and corrector. The "ndtfast/nfast" is
1340! becasue we do "nfast" steps to here.
1341!
1342 fac=0.5_r8*dtfast(ng)*ndtfast(ng)/(nfast(ng)*dt(ng))
1343 DO j=jstr,jend
1344 DO i=istr,iend
1345!^ cff=fac*(bed_thick(i,j,nstp)-bed_thick(i,j,nnew))
1346!^
1347 tl_cff=fac*(tl_bed_thick(i,j,nstp)-tl_bed_thick(i,j,nnew))
1348!^ h(i,j)=h(i,j)-cff
1349!^
1350 tl_h(i,j)=tl_h(i,j)-tl_cff
1351 END DO
1352 END DO
1353#endif
1354!
1355! Set free-surface lateral boundary conditions.
1356!
1357!^ CALL zetabc_tile (ng, tile, &
1358!^ & LBi, UBi, LBj, UBj, &
1359!^ & IminS, ImaxS, JminS, JmaxS, &
1360!^ & krhs, kstp, knew, &
1361!^ & zeta)
1362!^
1363 CALL tl_zetabc_tile (ng, tile, &
1364 & lbi, ubi, lbj, ubj, &
1365 & imins, imaxs, jmins, jmaxs, &
1366 & krhs, kstp, knew, &
1367 & zeta, tl_zeta)
1368
1369 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
1370!^ CALL exchange_r2d_tile (ng, tile, &
1371!^ & LBi, UBi, LBj, UBj, &
1372!^ & zeta(:,:,knew))
1373!^
1374 CALL exchange_r2d_tile (ng, tile, &
1375 & lbi, ubi, lbj, ubj, &
1376 & tl_zeta(:,:,knew))
1377 END IF
1378
1379#ifdef DISTRIBUTE
1380!^ CALL mp_exchange2d (ng, tile, iNLM, 1, &
1381!^ & LBi, UBi, LBj, UBj, &
1382!^ & NghostPoints, &
1383!^ & EWperiodic(ng), NSperiodic(ng), &
1384!^ & zeta(:,:,knew))
1385!^
1386 CALL mp_exchange2d (ng, tile, itlm, 1, &
1387 & lbi, ubi, lbj, ubj, &
1388 & nghostpoints, &
1389 & ewperiodic(ng), nsperiodic(ng), &
1390 & tl_zeta(:,:,knew))
1391#endif
1392!
1393!=======================================================================
1394! Compute right-hand-side for the 2D momentum equations.
1395!=======================================================================
1396!
1397!-----------------------------------------------------------------------
1398! Compute pressure gradient terms.
1399!-----------------------------------------------------------------------
1400!
1401 cff1=0.5_r8*g
1402 cff2=1.0_r8/3.0_r8
1403#if !defined SOLVE3D && defined ATM_PRESS
1404 fac3=0.5_r8*100.0_r8/rho0
1405#endif
1406 DO j=jstr,jend
1407 DO i=istru,iend
1408!^ rhs_ubar(i,j)=cff1*on_u(i,j)* &
1409!^ & ((h(i-1,j)+ &
1410!^ & h(i ,j))* &
1411!^ & (gzeta(i-1,j)- &
1412!^ & gzeta(i ,j))+ &
1413#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1414!^ & (h(i-1,j)- &
1415!^ & h(i ,j))* &
1416!^ & (gzetaSA(i-1,j)+ &
1417!^ & gzetaSA(i ,j)+ &
1418!^ & cff2*(rhoA(i-1,j)- &
1419!^ & rhoA(i ,j))* &
1420!^ & (zwrk(i-1,j)- &
1421!^ & zwrk(i ,j)))+ &
1422#endif
1423!^ & (gzeta2(i-1,j)- &
1424!^ & gzeta2(i ,j)))
1425!^
1426 tl_rhs_ubar(i,j)=cff1*on_u(i,j)* &
1427 & ((tl_h(i-1,j)+ &
1428 & tl_h(i ,j))* &
1429 & (gzeta(i-1,j)- &
1430 & gzeta(i ,j))+ &
1431 & (h(i-1,j)+ &
1432 & h(i ,j))* &
1433 & (tl_gzeta(i-1,j)- &
1434 & tl_gzeta(i ,j))+ &
1435#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1436 & (tl_h(i-1,j)- &
1437 & tl_h(i ,j))* &
1438 & (gzetasa(i-1,j)+ &
1439 & gzetasa(i ,j)+ &
1440 & cff2*(rhoa(i-1,j)- &
1441 & rhoa(i ,j))* &
1442 & (zwrk(i-1,j)- &
1443 & zwrk(i ,j)))+ &
1444 & (h(i-1,j)- &
1445 & h(i ,j))* &
1446 & (tl_gzetasa(i-1,j)+ &
1447 & tl_gzetasa(i ,j)+ &
1448 & cff2*((tl_rhoa(i-1,j)- &
1449 & tl_rhoa(i ,j))* &
1450 & (zwrk(i-1,j)- &
1451 & zwrk(i ,j))+ &
1452 & (rhoa(i-1,j)- &
1453 & rhoa(i ,j))* &
1454 & (tl_zwrk(i-1,j)- &
1455 & tl_zwrk(i ,j))))+ &
1456#endif
1457 & (tl_gzeta2(i-1,j)- &
1458 & tl_gzeta2(i ,j)))
1459#if defined ATM_PRESS && !defined SOLVE3D
1460!^ rhs_ubar(i,j)=rhs_ubar(i,j)- &
1461!^ & fac3*on_u(i,j)* &
1462!^ & (h(i-1,j)+h(i,j)+ &
1463!^ & gzeta(i-1,j)+gzeta(i,j))* &
1464!^ & (Pair(i,j)-Pair(i-1,j))
1465!^
1466 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)- &
1467 & fac3*on_u(i,j)* &
1468 & (tl_h(i-1,j)+tl_h(i,j)+ &
1469 & tl_gzeta(i-1,j)+tl_gzeta(i,j))* &
1470 & (pair(i,j)-pair(i-1,j))
1471#endif
1472#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1473!^ rhs_ubar(i,j)=rhs_ubar(i,j)- &
1474!^ & cff1*on_u(i,j)* &
1475!^ & (h(i-1,j)+h(i,j)+ &
1476!^ & gzeta(i-1,j)+gzeta(i,j))* &
1477!^ & (eq_tide(i,j)-eq_tide(i-1,j))
1478!^
1479 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)- &
1480 & cff1*on_u(i,j)* &
1481 & ((tl_h(i-1,j)+tl_h(i,j)+ &
1482 & tl_gzeta(i-1,j)+tl_gzeta(i,j))* &
1483 & (eq_tide(i,j)-eq_tide(i-1,j))+ &
1484 & (h(i-1,j)+h(i,j)+ &
1485 & gzeta(i-1,j)+gzeta(i,j))* &
1486 & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
1487#endif
1488#ifdef DIAGNOSTICS_UV
1489!! DiaU2rhs(i,j,M2pgrd)=rhs_ubar(i,j)
1490#endif
1491 END DO
1492 IF (j.ge.jstrv) THEN
1493 DO i=istr,iend
1494!^ rhs_vbar(i,j)=cff1*om_v(i,j)* &
1495!^ & ((h(i,j-1)+ &
1496!^ & h(i,j ))* &
1497!^ & (gzeta(i,j-1)- &
1498!^ & gzeta(i,j ))+ &
1499#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1500!^ & (h(i,j-1)- &
1501!^ & h(i,j ))* &
1502!^ & (gzetaSA(i,j-1)+ &
1503!^ & gzetaSA(i,j )+ &
1504!^ & cff2*(rhoA(i,j-1)- &
1505!^ & rhoA(i,j ))* &
1506!^ & (zwrk(i,j-1)- &
1507!^ & zwrk(i,j )))+ &
1508#endif
1509!^ & (gzeta2(i,j-1)- &
1510!^ & gzeta2(i,j )))
1511!^
1512 tl_rhs_vbar(i,j)=cff1*om_v(i,j)* &
1513 & ((tl_h(i,j-1)+ &
1514 & tl_h(i,j ))* &
1515 & (gzeta(i,j-1)- &
1516 & gzeta(i,j ))+ &
1517 & (h(i,j-1)+ &
1518 & h(i,j ))* &
1519 & (tl_gzeta(i,j-1)- &
1520 & tl_gzeta(i,j ))+ &
1521#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D
1522 & (tl_h(i,j-1)- &
1523 & tl_h(i,j ))* &
1524 & (gzetasa(i,j-1)+ &
1525 & gzetasa(i,j )+ &
1526 & cff2*(rhoa(i,j-1)- &
1527 & rhoa(i,j ))* &
1528 & (zwrk(i,j-1)- &
1529 & zwrk(i,j )))+ &
1530 & (h(i,j-1)- &
1531 & h(i,j ))* &
1532 & (tl_gzetasa(i,j-1)+ &
1533 & tl_gzetasa(i,j )+ &
1534 & cff2*((tl_rhoa(i,j-1)- &
1535 & tl_rhoa(i,j ))* &
1536 & (zwrk(i,j-1)- &
1537 & zwrk(i,j ))+ &
1538 & (rhoa(i,j-1)- &
1539 & rhoa(i,j ))* &
1540 & (tl_zwrk(i,j-1)- &
1541 & tl_zwrk(i,j ))))+ &
1542#endif
1543 & (tl_gzeta2(i,j-1)- &
1544 & tl_gzeta2(i,j )))
1545#if defined ATM_PRESS && !defined SOLVE3D
1546!^ rhs_vbar(i,j)=rhs_vbar(i,j)- &
1547!^ & fac3*om_v(i,j)* &
1548!^ & (h(i,j-1)+h(i,j)+ &
1549!^ & gzeta(i,j-1)+gzeta(i,j))* &
1550!^ & (Pair(i,j)-Pair(i,j-1))
1551!^
1552 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)- &
1553 & fac3*om_v(i,j)* &
1554 & (tl_h(i,j-1)+tl_h(i,j)+ &
1555 & tl_gzeta(i,j-1)+tl_gzeta(i,j))* &
1556 & (pair(i,j)-pair(i,j-1))
1557#endif
1558#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1559!^ rhs_vbar(i,j)=rhs_vbar(i,j)- &
1560!^ & cff1*om_v(i,j)* &
1561!^ & (h(i,j-1)+h(i,j)+ &
1562!^ & gzeta(i,j-1)+gzeta(i,j))* &
1563!^ & (eq_tide(i,j)-eq_tide(i,j-1))
1564!^
1565 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)- &
1566 & cff1*om_v(i,j)* &
1567 & ((tl_h(i,j-1)+tl_h(i,j)+ &
1568 & tl_gzeta(i,j-1)+tl_gzeta(i,j))* &
1569 & (eq_tide(i,j)-eq_tide(i,j-1))+ &
1570 & (h(i,j-1)+h(i,j)+ &
1571 & gzeta(i,j-1)+gzeta(i,j))* &
1572 & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
1573#endif
1574#ifdef DIAGNOSTICS_UV
1575!! DiaV2rhs(i,j,M2pgrd)=rhs_vbar(i,j)
1576#endif
1577 END DO
1578 END IF
1579 END DO
1580#ifdef UV_ADV
1581!
1582!-----------------------------------------------------------------------
1583! Add in horizontal advection of momentum.
1584!-----------------------------------------------------------------------
1585
1586# ifdef UV_C2ADVECTION
1587!
1588! Second-order, centered differences advection.
1589!
1590 DO j=jstr,jend
1591 DO i=istru-1,iend
1592!^ UFx(i,j)=0.25_r8*(DUon(i,j)+DUon(i+1,j))* &
1593!^ & (ubar(i ,j,krhs)+ &
1594# ifdef WEC_MELLOR
1595!^ & ubar_stokes(i ,j)+ &
1596!^ & ubar_stokes(i+1,j)+ &
1597# endif
1598!^ & ubar(i+1,j,krhs))
1599!^
1600 tl_ufx(i,j)=0.25_r8* &
1601 & ((tl_duon(i,j)+tl_duon(i+1,j))* &
1602 & (ubar(i ,j,krhs)+ &
1603# ifdef WEC_MELLOR
1604 & ubar_stokes(i ,j)+ &
1605 & ubar_stokes(i+1,j)+ &
1606# endif
1607 & ubar(i+1,j,krhs))+ &
1608 & (duon(i,j)+duon(i+1,j))* &
1609 & (tl_ubar(i ,j,krhs)+ &
1610# ifdef WEC_MELLOR
1611 & tl_ubar_stokes(i ,j)+ &
1612 & tl_ubar_stokes(i+1,j)+ &
1613# endif
1614 & tl_ubar(i+1,j,krhs)))
1615 END DO
1616 END DO
1617!
1618 DO j=jstr,jend+1
1619 DO i=istru,iend
1620!^ UFe(i,j)=0.25_r8*(DVom(i,j)+DVom(i-1,j))* &
1621!^ & (ubar(i,j ,krhs)+ &
1622# ifdef WEC_MELLOR
1623!^ & ubar_stokes(i,j )+ &
1624!^ & ubar_stokes(i,j-1)+ &
1625# endif
1626!^ & ubar(i,j-1,krhs))
1627!^
1628 tl_ufe(i,j)=0.25_r8* &
1629 & ((tl_dvom(i,j)+tl_dvom(i-1,j))* &
1630 & (ubar(i,j ,krhs)+ &
1631# ifdef WEC_MELLOR
1632 & ubar_stokes(i,j )+ &
1633 & ubar_stokes(i,j-1)+ &
1634# endif
1635 & ubar(i,j-1,krhs))+ &
1636 & (dvom(i,j)+dvom(i-1,j))* &
1637 & (tl_ubar(i,j ,krhs)+ &
1638# ifdef WEC_MELLOR
1639 & tl_ubar_stokes(i,j )+ &
1640 & tl_ubar_stokes(i,j-1)+ &
1641# endif
1642 & tl_ubar(i,j-1,krhs)))
1643 END DO
1644 END DO
1645!
1646 DO j=jstrv,jend
1647 DO i=istr,iend+1
1648!^ VFx(i,j)=0.25_r8*(DUon(i,j)+DUon(i,j-1))* &
1649!^ & (vbar(i ,j,krhs)+ &
1650# ifdef WEC_MELLOR
1651!^ & vbar_stokes(i ,j)+ &
1652!^ & vbar_stokes(i-1,j)+ &
1653# endif
1654!^ & vbar(i-1,j,krhs))
1655!^
1656 tl_vfx(i,j)=0.25_r8* &
1657 & ((tl_duon(i,j)+tl_duon(i,j-1))* &
1658 & (vbar(i ,j,krhs)+ &
1659# ifdef WEC_MELLOR
1660 & vbar_stokes(i ,j)+ &
1661 & vbar_stokes(i-1,j)+ &
1662# endif
1663 & vbar(i-1,j,krhs))+ &
1664 & (duon(i,j)+duon(i,j-1))* &
1665 & (tl_vbar(i ,j,krhs)+ &
1666# ifdef WEC_MELLOR
1667 & tl_vbar_stokes(i ,j)+ &
1668 & tl_vbar_stokes(i-1,j)+ &
1669# endif
1670 & tl_vbar(i-1,j,krhs)))
1671 END DO
1672 END DO
1673!
1674 DO j=jstrv-1,jend
1675 DO i=istr,iend
1676!^ VFe(i,j)=0.25_r8*(DVom(i,j)+DVom(i,j+1))* &
1677!^ & (vbar(i,j ,krhs)+ &
1678# ifdef WEC_MELLOR
1679!^ & vbar_stokes(i,j )+ &
1680!^ & vbar_stokes(i,j+1)+ &
1681# endif
1682!^ & vbar(i,j+1,krhs))
1683!^
1684 tl_vfe(i,j)=0.25_r8* &
1685 & ((tl_dvom(i,j)+tl_dvom(i,j+1))* &
1686 & (vbar(i,j ,krhs)+ &
1687# ifdef WEC_MELLOR
1688 & vbar_stokes(i,j )+ &
1689 & vbar_stokes(i,j+1)+ &
1690# endif
1691 & vbar(i,j+1,krhs))+ &
1692 & (dvom(i,j)+dvom(i,j+1))* &
1693 & (tl_vbar(i,j ,krhs)+ &
1694# ifdef WEC_MELLOR
1695 & tl_vbar_stokes(i,j )+ &
1696 & tl_vbar_stokes(i,j+1)+ &
1697# endif
1698 & tl_vbar(i,j+1,krhs)))
1699 END DO
1700 END DO
1701# else
1702!
1703! Fourth-order, centered differences advection.
1704!
1705 DO j=jstr,jend
1706 DO i=istrum1,iendp1
1707 grad(i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1708# ifdef WEC_MELLOR
1709 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
1710 & ubar_stokes(i+1,j)+ &
1711# endif
1712 & ubar(i+1,j,krhs)
1713 tl_grad(i,j)=tl_ubar(i-1,j,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1714# ifdef WEC_MELLOR
1715 & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
1716 & tl_ubar_stokes(i+1,j)+ &
1717# endif
1718 & tl_ubar(i+1,j,krhs)
1719 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
1720 tl_dgrad(i,j)=tl_duon(i-1,j)-2.0_r8*tl_duon(i,j)+ &
1721 & tl_duon(i+1,j)
1722 END DO
1723 END DO
1724 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1725 IF (domain(ng)%Western_Edge(tile)) THEN
1726 DO j=jstr,jend
1727 grad(istr,j)=grad(istr+1,j)
1728 tl_grad(istr,j)=tl_grad(istr+1,j)
1729 dgrad(istr,j)=dgrad(istr+1,j)
1730 tl_dgrad(istr,j)=tl_dgrad(istr+1,j)
1731 END DO
1732 END IF
1733 END IF
1734 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1735 IF (domain(ng)%Eastern_Edge(tile)) THEN
1736 DO j=jstr,jend
1737 grad(iend+1,j)=grad(iend,j)
1738 tl_grad(iend+1,j)=tl_grad(iend,j)
1739 dgrad(iend+1,j)=dgrad(iend,j)
1740 tl_dgrad(iend+1,j)=tl_dgrad(iend,j)
1741 END DO
1742 END IF
1743 END IF
1744
1745 cff=1.0_r8/6.0_r8
1746 DO j=jstr,jend
1747 DO i=istru-1,iend
1748!^ UFx(i,j)=0.25_r8*(ubar(i ,j,krhs)+ &
1749# ifdef WEC_MELLOR
1750!^ & ubar_stokes(i ,j)+ &
1751!^ & ubar_stokes(i+1,j)+ &
1752# endif
1753!^ & ubar(i+1,j,krhs)- &
1754!^ & cff*(grad (i,j)+grad (i+1,j)))* &
1755!^ & (DUon(i,j)+DUon(i+1,j)- &
1756!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j)))
1757!^
1758 tl_ufx(i,j)=0.25_r8* &
1759 & ((ubar(i ,j,krhs)+ &
1760# ifdef WEC_MELLOR
1761 & ubar_stokes(i ,j)+ &
1762 & ubar_stokes(i+1,j)+ &
1763# endif
1764 & ubar(i+1,j,krhs)- &
1765 & cff*(grad(i,j)+grad(i+1,j)))* &
1766 & (tl_duon(i,j)+tl_duon(i+1,j)- &
1767 & cff*(tl_dgrad(i,j)+tl_dgrad(i+1,j)))+ &
1768 & (tl_ubar(i ,j,krhs)+ &
1769# ifdef WEC_MELLOR
1770 & tl_ubar_stokes(i ,j)+ &
1771 & tl_ubar_stokes(i+1,j)+ &
1772# endif
1773 & tl_ubar(i+1,j,krhs)- &
1774 & cff*(tl_grad(i,j)+tl_grad(i+1,j)))* &
1775 & (duon(i,j)+duon(i+1,j)- &
1776 & cff*(dgrad(i,j)+dgrad(i+1,j))))
1777 END DO
1778 END DO
1779!
1780 DO j=jstrm1,jendp1
1781 DO i=istru,iend
1782 grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1783# ifdef WEC_MELLOR
1784 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
1785 & ubar_stokes(i,j+1)+ &
1786# endif
1787 & ubar(i,j+1,krhs)
1788 tl_grad(i,j)=tl_ubar(i,j-1,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1789# ifdef WEC_MELLOR
1790 & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
1791 & tl_ubar_stokes(i,j+1)+ &
1792# endif
1793 & tl_ubar(i,j+1,krhs)
1794 END DO
1795 END DO
1796 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1797 IF (domain(ng)%Southern_Edge(tile)) THEN
1798 DO i=istru,iend
1799 grad(i,jstr-1)=grad(i,jstr)
1800 tl_grad(i,jstr-1)=tl_grad(i,jstr)
1801 END DO
1802 END IF
1803 END IF
1804 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1805 IF (domain(ng)%Northern_Edge(tile)) THEN
1806 DO i=istru,iend
1807 grad(i,jend+1)=grad(i,jend)
1808 tl_grad(i,jend+1)=tl_grad(i,jend)
1809 END DO
1810 END IF
1811 END IF
1812 DO j=jstr,jend+1
1813 DO i=istru-1,iend
1814 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
1815 tl_dgrad(i,j)=tl_dvom(i-1,j)-2.0_r8*tl_dvom(i,j)+ &
1816 & tl_dvom(i+1,j)
1817 END DO
1818 END DO
1819
1820 cff=1.0_r8/6.0_r8
1821 DO j=jstr,jend+1
1822 DO i=istru,iend
1823!^ UFe(i,j)=0.25_r8*(ubar(i,j ,krhs)+ &
1824# ifdef WEC_MELLOR
1825!^ & ubar_stokes(i,j )+ &
1826!^ & ubar_stokes(i,j-1)+ &
1827# endif
1828!^ & ubar(i,j-1,krhs)- &
1829!^ & cff*(grad (i,j)+grad (i,j-1)))* &
1830!^ & (DVom(i,j)+DVom(i-1,j)- &
1831!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))
1832!^
1833 tl_ufe(i,j)=0.25_r8* &
1834 & ((tl_ubar(i,j ,krhs)+ &
1835# ifdef WEC_MELLOR
1836 & tl_ubar_stokes(i,j )+ &
1837 & tl_ubar_stokes(i,j-1)+ &
1838# endif
1839 & tl_ubar(i,j-1,krhs)- &
1840 & cff*(tl_grad(i,j)+tl_grad(i,j-1)))* &
1841 & (dvom(i,j)+dvom(i-1,j)- &
1842 & cff*(dgrad(i,j)+dgrad(i-1,j)))+ &
1843 & (ubar(i,j ,krhs)+ &
1844# ifdef WEC_MELLOR
1845 & ubar_stokes(i,j )+ &
1846 & ubar_stokes(i,j-1)+ &
1847# endif
1848 & ubar(i,j-1,krhs)- &
1849 & cff*(grad(i,j)+grad(i,j-1)))* &
1850 & (tl_dvom(i,j)+tl_dvom(i-1,j)- &
1851 & cff*(tl_dgrad(i,j)+tl_dgrad(i-1,j))))
1852 END DO
1853 END DO
1854!
1855 DO j=jstrv,jend
1856 DO i=istrm1,iendp1
1857 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1858# ifdef WEC_MELLOR
1859 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
1860 & vbar_stokes(i+1,j)+ &
1861# endif
1862 & vbar(i+1,j,krhs)
1863 tl_grad(i,j)=tl_vbar(i-1,j,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1864# ifdef WEC_MELLOR
1865 & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
1866 & tl_vbar_stokes(i+1,j)+ &
1867# endif
1868 & tl_vbar(i+1,j,krhs)
1869 END DO
1870 END DO
1871 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1872 IF (domain(ng)%Western_Edge(tile)) THEN
1873 DO j=jstrv,jend
1874 grad(istr-1,j)=grad(istr,j)
1875 tl_grad(istr-1,j)=tl_grad(istr,j)
1876 END DO
1877 END IF
1878 END IF
1879 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1880 IF (domain(ng)%Eastern_Edge(tile)) THEN
1881 DO j=jstrv,jend
1882 grad(iend+1,j)=grad(iend,j)
1883 tl_grad(iend+1,j)=tl_grad(iend,j)
1884 END DO
1885 END IF
1886 END IF
1887 DO j=jstrv-1,jend
1888 DO i=istr,iend+1
1889 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
1890 tl_dgrad(i,j)=tl_duon(i,j-1)-2.0_r8*tl_duon(i,j)+ &
1891 & tl_duon(i,j+1)
1892 END DO
1893 END DO
1894
1895 cff=1.0_r8/6.0_r8
1896 DO j=jstrv,jend
1897 DO i=istr,iend+1
1898!^ VFx(i,j)=0.25_r8*(vbar(i ,j,krhs)+ &
1899# ifdef WEC_MELLOR
1900!^ & vbar_stokes(i ,j)+ &
1901!^ & vbar_stokes(i-1,j)+ &
1902# endif
1903!^ & vbar(i-1,j,krhs)- &
1904!^ & cff*(grad (i,j)+grad (i-1,j)))* &
1905!^ & (DUon(i,j)+DUon(i,j-1)- &
1906!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))
1907!^
1908 tl_vfx(i,j)=0.25_r8* &
1909 & ((tl_vbar(i ,j,krhs)+ &
1910# ifdef WEC_MELLOR
1911 & tl_vbar_stokes(i ,j)+ &
1912 & tl_vbar_stokes(i-1,j)+ &
1913# endif
1914 & tl_vbar(i-1,j,krhs)- &
1915 & cff*(tl_grad(i,j)+tl_grad(i-1,j)))* &
1916 & (duon(i,j)+duon(i,j-1)- &
1917 & cff*(dgrad(i,j)+dgrad(i,j-1)))+ &
1918 & (vbar(i ,j,krhs)+ &
1919# ifdef WEC_MELLOR
1920 & vbar_stokes(i ,j)+ &
1921 & vbar_stokes(i-1,j)+ &
1922# endif
1923 & vbar(i-1,j,krhs)- &
1924 & cff*(grad(i,j)+grad(i-1,j)))* &
1925 & (tl_duon(i,j)+tl_duon(i,j-1)- &
1926 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j-1))))
1927 END DO
1928 END DO
1929!
1930 DO j=jstrvm1,jendp1
1931 DO i=istr,iend
1932 grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1933# ifdef WEC_MELLOR
1934 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
1935 & vbar_stokes(i,j+1)+ &
1936# endif
1937 & vbar(i,j+1,krhs)
1938 tl_grad(i,j)=tl_vbar(i,j-1,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1939# ifdef WEC_MELLOR
1940 & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
1941 & tl_vbar_stokes(i,j+1)+ &
1942# endif
1943 & tl_vbar(i,j+1,krhs)
1944 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
1945 tl_dgrad(i,j)=tl_dvom(i,j-1)-2.0_r8*tl_dvom(i,j)+ &
1946 & tl_dvom(i,j+1)
1947 END DO
1948 END DO
1949 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1950 IF (domain(ng)%Southern_Edge(tile)) THEN
1951 DO i=istr,iend
1952 grad(i,jstr)=grad(i,jstr+1)
1953 tl_grad(i,jstr)=tl_grad(i,jstr+1)
1954 dgrad(i,jstr)=dgrad(i,jstr+1)
1955 tl_dgrad(i,jstr)=tl_dgrad(i,jstr+1)
1956 END DO
1957 END IF
1958 END IF
1959 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1960 IF (domain(ng)%Northern_Edge(tile)) THEN
1961 DO i=istr,iend
1962 grad(i,jend+1)=grad(i,jend)
1963 tl_grad(i,jend+1)=tl_grad(i,jend)
1964 dgrad(i,jend+1)=dgrad(i,jend)
1965 tl_dgrad(i,jend+1)=tl_dgrad(i,jend)
1966 END DO
1967 END IF
1968 END IF
1969
1970 cff=1.0_r8/6.0_r8
1971 DO j=jstrv-1,jend
1972 DO i=istr,iend
1973!^ VFe(i,j)=0.25_r8*(vbar(i,j ,krhs)+ &
1974# ifdef WEC_MELLOR
1975!^ & vbar_stokes(i,j )+ &
1976!^ & vbar_stokes(i,j+1)+ &
1977# endif
1978!^ & vbar(i,j+1,krhs)- &
1979!^ & cff*(grad (i,j)+grad (i,j+1)))* &
1980!^ & (DVom(i,j)+DVom(i,j+1)- &
1981!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))
1982!^
1983 tl_vfe(i,j)=0.25_r8* &
1984 & ((tl_vbar(i,j ,krhs)+ &
1985# ifdef WEC_MELLOR
1986 & tl_vbar_stokes(i,j )+ &
1987 & tl_vbar_stokes(i,j+1)+ &
1988# endif
1989 & tl_vbar(i,j+1,krhs)- &
1990 & cff*(tl_grad(i,j)+tl_grad(i,j+1)))* &
1991 & (dvom(i,j)+dvom(i,j+1)- &
1992 & cff*(dgrad(i,j)+dgrad(i,j+1)))+ &
1993 & (vbar(i,j ,krhs)+ &
1994# ifdef WEC_MELLOR
1995 & vbar_stokes(i,j )+ &
1996 & vbar_stokes(i,j+1)+ &
1997# endif
1998 & vbar(i,j+1,krhs)- &
1999 & cff*(grad(i,j)+grad(i,j+1)))* &
2000 & (tl_dvom(i,j)+tl_dvom(i,j+1)- &
2001 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j+1))))
2002 END DO
2003 END DO
2004# endif
2005!
2006 DO j=jstr,jend
2007 DO i=istru,iend
2008!^ cff1=UFx(i,j)-UFx(i-1,j)
2009!^
2010 tl_cff1=tl_ufx(i,j)-tl_ufx(i-1,j)
2011!^ cff2=UFe(i,j+1)-UFe(i,j)
2012!^
2013 tl_cff2=tl_ufe(i,j+1)-tl_ufe(i,j)
2014!^ fac=cff1+cff2
2015!^
2016 tl_fac=tl_cff1+tl_cff2
2017!^ rhs_ubar(i,j)=rhs_ubar(i,j)-fac
2018!^
2019 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_fac
2020# if defined DIAGNOSTICS_UV
2021!! DiaU2rhs(i,j,M2xadv)=-cff1
2022!! DiaU2rhs(i,j,M2yadv)=-cff2
2023!! DiaU2rhs(i,j,M2hadv)=-fac
2024# endif
2025 END DO
2026 END DO
2027 DO j=jstrv,jend
2028 DO i=istr,iend
2029!^ cff1=VFx(i+1,j)-VFx(i,j)
2030!^
2031 tl_cff1=tl_vfx(i+1,j)-tl_vfx(i,j)
2032!^ cff2=VFe(i,j)-VFe(i,j-1)
2033!^
2034 tl_cff2=tl_vfe(i,j)-tl_vfe(i,j-1)
2035!^ fac=cff1+cff2
2036!^
2037 tl_fac=tl_cff1+tl_cff2
2038!^ rhs_vbar(i,j)=rhs_vbar(i,j)-fac
2039!^
2040 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac
2041# if defined DIAGNOSTICS_UV
2042!! DiaV2rhs(i,j,M2xadv)=-cff1
2043!! DiaV2rhs(i,j,M2yadv)=-cff2
2044!! DiaV2rhs(i,j,M2hadv)=-fac
2045# endif
2046 END DO
2047 END DO
2048#endif
2049#ifdef UV_COR
2050!
2051!-----------------------------------------------------------------------
2052! Add in Coriolis term.
2053!-----------------------------------------------------------------------
2054!
2055 DO j=jstrv-1,jend
2056 DO i=istru-1,iend
2057 cff=0.5_r8*drhs(i,j)*fomn(i,j)
2058 tl_cff=0.5_r8*tl_drhs(i,j)*fomn(i,j)
2059!^ UFx(i,j)=cff*(vbar(i,j ,krhs)+ &
2060# ifdef WEC_MELLOR
2061!^ & vbar_stokes(i,j )+ &
2062!^ & vbar_stokes(i,j+1)+ &
2063# endif
2064!^ & vbar(i,j+1,krhs))
2065!^
2066 tl_ufx(i,j)=tl_cff*(vbar(i,j ,krhs)+ &
2067# ifdef WEC_MELLOR
2068 & vbar_stokes(i,j )+ &
2069 & vbar_stokes(i,j+1)+ &
2070# endif
2071 & vbar(i,j+1,krhs))+ &
2072 & cff*(tl_vbar(i,j ,krhs)+ &
2073# ifdef WEC_MELLOR
2074 & tl_vbar_stokes(i,j )+ &
2075 & tl_vbar_stokes(i,j+1)+ &
2076# endif
2077 & tl_vbar(i,j+1,krhs))
2078!^ VFe(i,j)=cff*(ubar(i ,j,krhs)+ &
2079# ifdef WEC_MELLOR
2080!^ & ubar_stokes(i ,j)+ &
2081!^ & ubar_stokes(i+1,j)+ &
2082# endif
2083!^ & ubar(i+1,j,krhs))
2084!^
2085 tl_vfe(i,j)=tl_cff*(ubar(i ,j,krhs)+ &
2086# ifdef WEC_MELLOR
2087 & ubar_stokes(i ,j)+ &
2088 & ubar_stokes(i+1,j)+ &
2089# endif
2090 & ubar(i+1,j,krhs))+ &
2091 & cff*(tl_ubar(i ,j,krhs)+ &
2092# ifdef WEC_MELLOR
2093 & tl_ubar_stokes(i ,j)+ &
2094 & tl_ubar_stokes(i+1,j)+ &
2095# endif
2096 & tl_ubar(i+1,j,krhs))
2097 END DO
2098 END DO
2099 DO j=jstr,jend
2100 DO i=istru,iend
2101!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
2102!^
2103 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
2104!^ rhs_ubar(i,j)=rhs_ubar(i,j)+fac1
2105!^
2106 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac1
2107# if defined DIAGNOSTICS_UV
2108!! DiaU2rhs(i,j,M2fcor)=fac1
2109# endif
2110 END DO
2111 END DO
2112 DO j=jstrv,jend
2113 DO i=istr,iend
2114!^ fac1=0.5_r8*(VFe(i,j)+VFe(i,j-1))
2115!^
2116 tl_fac1=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
2117!^ rhs_vbar(i,j)=rhs_vbar(i,j)-fac1
2118!^
2119 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac1
2120# if defined DIAGNOSTICS_UV
2121!! DiaV2rhs(i,j,M2fcor)=-fac1
2122# endif
2123 END DO
2124 END DO
2125#endif
2126#if defined CURVGRID && defined UV_ADV
2127!
2128!-----------------------------------------------------------------------
2129! Add in curvilinear transformation terms.
2130!-----------------------------------------------------------------------
2131!
2132 DO j=jstrv-1,jend
2133 DO i=istru-1,iend
2134 cff1=0.5_r8*(vbar(i,j ,krhs)+ &
2135# ifdef WEC_MELLOR
2136 & vbar_stokes(i,j )+ &
2137 & vbar_stokes(i,j+1)+ &
2138# endif
2139 & vbar(i,j+1,krhs))
2140 tl_cff1=0.5_r8*(tl_vbar(i,j ,krhs)+ &
2141# ifdef WEC_MELLOR
2142 & tl_vbar_stokes(i,j )+ &
2143 & tl_vbar_stokes(i,j+1)+ &
2144# endif
2145 & tl_vbar(i,j+1,krhs))
2146 cff2=0.5_r8*(ubar(i ,j,krhs)+ &
2147# ifdef WEC_MELLOR
2148 & ubar_stokes(i ,j)+ &
2149 & ubar_stokes(i+1,j)+ &
2150# endif
2151 & ubar(i+1,j,krhs))
2152 tl_cff2=0.5_r8*(tl_ubar(i ,j,krhs)+ &
2153# ifdef WEC_MELLOR
2154 & tl_ubar_stokes(i ,j)+ &
2155 & tl_ubar_stokes(i+1,j)+ &
2156# endif
2157 & tl_ubar(i+1,j,krhs))
2158 cff3=cff1*dndx(i,j)
2159 tl_cff3=tl_cff1*dndx(i,j)
2160 cff4=cff2*dmde(i,j)
2161 tl_cff4=tl_cff2*dmde(i,j)
2162 cff=drhs(i,j)*(cff3-cff4)
2163 tl_cff=tl_drhs(i,j)*(cff3-cff4)+ &
2164 & drhs(i,j)*(tl_cff3-tl_cff4)
2165!^ UFx(i,j)=cff*cff1
2166!^
2167 tl_ufx(i,j)=tl_cff*cff1+cff*tl_cff1
2168!^ VFe(i,j)=cff*cff2
2169!^
2170 tl_vfe(i,j)=tl_cff*cff2+cff*tl_cff2
2171# if defined DIAGNOSTICS_UV
2172!! cff=Drhs(i,j)*cff4
2173!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
2174!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
2175# endif
2176 END DO
2177 END DO
2178 DO j=jstr,jend
2179 DO i=istru,iend
2180!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
2181!^
2182 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
2183!^ rhs_ubar(i,j)=rhs_ubar(i,j)+fac1
2184!^
2185 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac1
2186# if defined DIAGNOSTICS_UV
2187!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
2188!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
2189!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
2190!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
2191# endif
2192 END DO
2193 END DO
2194 DO j=jstrv,jend
2195 DO i=istr,iend
2196!^ fac1=0.5_r8*(VFe(i,j)+VFe(i,j-1))
2197!^
2198 tl_fac1=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
2199!^ rhs_vbar(i,j)=rhs_vbar(i,j)-fac1
2200!^
2201 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac1
2202# if defined DIAGNOSTICS_UV
2203!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
2204!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
2205!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
2206!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
2207# endif
2208 END DO
2209 END DO
2210#endif
2211#if defined UV_VIS2 || defined UV_VIS4
2212!
2213!-----------------------------------------------------------------------
2214! If horizontal mixing, compute total depth at PSI-points.
2215!-----------------------------------------------------------------------
2216!
2217# ifdef UV_VIS4
2218 DO j=jstrm1,jendp2
2219 DO i=istrm1,iendp2
2220# else
2221 DO j=jstr,jend+1
2222 DO i=istr,iend+1
2223# endif
2224 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2225 & drhs(i,j-1)+drhs(i-1,j-1))
2226 tl_drhs_p(i,j)=0.25_r8*(tl_drhs(i,j )+tl_drhs(i-1,j )+ &
2227 & tl_drhs(i,j-1)+tl_drhs(i-1,j-1))
2228 END DO
2229 END DO
2230#endif
2231#ifdef UV_VIS2
2232!
2233!-----------------------------------------------------------------------
2234! Add in horizontal harmonic viscosity.
2235!-----------------------------------------------------------------------
2236!
2237! Compute flux-components of the horizontal divergence of the stress
2238! tensor (m5/s2) in XI- and ETA-directions.
2239!
2240 DO j=jstrv-1,jend
2241 DO i=istru-1,iend
2242!^ cff=visc2_r(i,j)*Drhs(i,j)*0.5_r8* &
2243!^ & (pmon_r(i,j)* &
2244!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2245!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2246!^ & pnom_r(i,j)* &
2247!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2248!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))
2249!^
2250 tl_cff=visc2_r(i,j)*0.5_r8* &
2251 & (tl_drhs(i,j)* &
2252 & (pmon_r(i,j)* &
2253 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2254 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2255 & pnom_r(i,j)* &
2256 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2257 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))+ &
2258 & drhs(i,j)* &
2259 & (pmon_r(i,j)* &
2260 & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2261 & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2262 & pnom_r(i,j)* &
2263 & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2264 & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs))))
2265!^ UFx(i,j)=on_r(i,j)*on_r(i,j)*cff
2266!^
2267 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2268!^ VFe(i,j)=om_r(i,j)*om_r(i,j)*cff
2269!^
2270 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2271 END DO
2272 END DO
2273 DO j=jstr,jend+1
2274 DO i=istr,iend+1
2275!^ cff=visc2_p(i,j)*Drhs_p(i,j)*0.5_r8* &
2276!^ & (pmon_p(i,j)* &
2277!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2278!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2279!^ & pnom_p(i,j)* &
2280!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2281!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))
2282!^
2283 tl_cff=visc2_p(i,j)*0.5_r8* &
2284 & (tl_drhs_p(i,j)* &
2285 & (pmon_p(i,j)* &
2286 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2287 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2288 & pnom_p(i,j)* &
2289 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2290 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))+ &
2291 & drhs_p(i,j)* &
2292 & (pmon_p(i,j)* &
2293 & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2294 & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2295 & pnom_p(i,j)* &
2296 & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2297 & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs))))
2298# ifdef MASKING
2299!^ cff=cff*pmask(i,j)
2300!^
2301 tl_cff=tl_cff*pmask(i,j)
2302# endif
2303!^ UFe(i,j)=om_p(i,j)*om_p(i,j)*cff
2304!^
2305 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2306!^ VFx(i,j)=on_p(i,j)*on_p(i,j)*cff
2307!^
2308 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2309 END DO
2310 END DO
2311!
2312! Add in harmonic viscosity.
2313!
2314 DO j=jstr,jend
2315 DO i=istru,iend
2316!^ cff1=0.5_r8*(pn(i-1,j)+pn(i,j))*(UFx(i,j )-UFx(i-1,j))
2317!^
2318 tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2319 & (tl_ufx(i,j )-tl_ufx(i-1,j))
2320!^ cff2=0.5_r8*(pm(i-1,j)+pm(i,j))*(UFe(i,j+1)-UFe(i ,j))
2321!^
2322 tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2323 & (tl_ufe(i,j+1)-tl_ufe(i ,j))
2324!^ fac=cff1+cff2
2325!^
2326 tl_fac=tl_cff1+tl_cff2
2327!^ rhs_ubar(i,j)=rhs_ubar(i,j)+fac
2328!^
2329 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac
2330# if defined DIAGNOSTICS_UV
2331!! DiaU2rhs(i,j,M2hvis)=fac
2332!! DiaU2rhs(i,j,M2xvis)=cff1
2333!! DiaU2rhs(i,j,M2yvis)=cff2
2334# endif
2335 END DO
2336 END DO
2337 DO j=jstrv,jend
2338 DO i=istr,iend
2339!^ cff1=0.5_r8*(pn(i,j-1)+pn(i,j))*(VFx(i+1,j)-VFx(i,j ))
2340!^
2341 tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2342 & (tl_vfx(i+1,j)-tl_vfx(i,j ))
2343!^ cff2=0.5_r8*(pm(i,j-1)+pm(i,j))*(VFe(i ,j)-VFe(i,j-1))
2344!^
2345 tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2346 & (tl_vfe(i ,j)-tl_vfe(i,j-1))
2347!^ fac=cff1-cff2
2348!^
2349 tl_fac=tl_cff1-tl_cff2
2350!^ rhs_vbar(i,j)=rhs_vbar(i,j)+fac
2351!^
2352 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_fac
2353# if defined DIAGNOSTICS_UV
2354!! DiaV2rhs(i,j,M2hvis)=fac
2355!! DiaV2rhs(i,j,M2xvis)= cff1
2356!! DiaV2rhs(i,j,M2yvis)=-cff2
2357# endif
2358 END DO
2359 END DO
2360#endif
2361#ifdef UV_VIS4
2362!
2363!-----------------------------------------------------------------------
2364! Add in horizontal biharmonic viscosity. The biharmonic operator
2365! is computed by applying the harmonic operator twice.
2366!-----------------------------------------------------------------------
2367!
2368! Compute flux-components of the horizontal divergence of the stress
2369! tensor (m4 s^-3/2) in XI- and ETA-directions. It is assumed here
2370! that "visc4_r" and "visc4_p" are the squared root of the biharmonic
2371! viscosity coefficient. For momentum balance purposes, the total
2372! thickness "D" appears only when computing the second harmonic
2373! operator.
2374!
2375 DO j=jstrvm2,jendp1
2376 DO i=istrum2,iendp1
2377 cff=visc4_r(i,j)*0.5_r8* &
2378 & (pmon_r(i,j)* &
2379 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2380 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2381 & pnom_r(i,j)* &
2382 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2383 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))
2384 tl_cff=visc4_r(i,j)*0.5_r8* &
2385 & (pmon_r(i,j)* &
2386 & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2387 & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2388 & pnom_r(i,j)* &
2389 & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2390 & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs)))
2391 ufx(i,j)=on_r(i,j)*on_r(i,j)*cff
2392 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2393 vfe(i,j)=om_r(i,j)*om_r(i,j)*cff
2394 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2395 END DO
2396 END DO
2397 DO j=jstrm1,jendp2
2398 DO i=istrm1,iendp2
2399 cff=visc4_p(i,j)*0.5_r8* &
2400 & (pmon_p(i,j)* &
2401 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2402 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2403 & pnom_p(i,j)* &
2404 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2405 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))
2406 tl_cff=visc4_p(i,j)*0.5_r8* &
2407 & (pmon_p(i,j)* &
2408 & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2409 & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2410 & pnom_p(i,j)* &
2411 & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2412 & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs)))
2413# ifdef MASKING
2414 cff=cff*pmask(i,j)
2415 tl_cff=tl_cff*pmask(i,j)
2416# endif
2417 ufe(i,j)=om_p(i,j)*om_p(i,j)*cff
2418 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2419 vfx(i,j)=on_p(i,j)*on_p(i,j)*cff
2420 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2421 END DO
2422 END DO
2423!
2424! Compute first harmonic operator (m s^-3/2).
2425!
2426 DO j=jstrm1,jendp1
2427 DO i=istrum1,iendp1
2428 lapu(i,j)=0.125_r8* &
2429 & (pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))* &
2430 & ((pn(i-1,j)+pn(i,j))* &
2431 & (ufx(i,j )-ufx(i-1,j))+ &
2432 & (pm(i-1,j)+pm(i,j))* &
2433 & (ufe(i,j+1)-ufe(i ,j)))
2434 tl_lapu(i,j)=0.125_r8* &
2435 & (pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))* &
2436 & ((pn(i-1,j)+pn(i,j))* &
2437 & (tl_ufx(i,j )-tl_ufx(i-1,j))+ &
2438 & (pm(i-1,j)+pm(i,j))* &
2439 & (tl_ufe(i,j+1)-tl_ufe(i ,j)))
2440 END DO
2441 END DO
2442 DO j=jstrvm1,jendp1
2443 DO i=istrm1,iendp1
2444 lapv(i,j)=0.125_r8* &
2445 & (pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))* &
2446 & ((pn(i,j-1)+pn(i,j))* &
2447 & (vfx(i+1,j)-vfx(i,j ))- &
2448 & (pm(i,j-1)+pm(i,j))* &
2449 & (vfe(i ,j)-vfe(i,j-1)))
2450 tl_lapv(i,j)=0.125_r8* &
2451 & (pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))* &
2452 & ((pn(i,j-1)+pn(i,j))* &
2453 & (tl_vfx(i+1,j)-tl_vfx(i,j ))- &
2454 & (pm(i,j-1)+pm(i,j))* &
2455 & (tl_vfe(i ,j)-tl_vfe(i,j-1)))
2456 END DO
2457 END DO
2458!
2459! Apply boundary conditions (other than periodic) to the first
2460! harmonic operator. These are gradient or closed (free slip or
2461! no slip) boundary conditions.
2462!
2463 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2464 IF (domain(ng)%Western_Edge(tile)) THEN
2465 IF (tl_lbc(iwest,isubar,ng)%closed) THEN
2466 DO j=jstrm1,jendp1
2467 lapu(istru-1,j)=0.0_r8
2468 tl_lapu(istru-1,j)=0.0_r8
2469 END DO
2470 ELSE
2471 DO j=jstrm1,jendp1
2472 lapu(istru-1,j)=lapu(istru,j)
2473 tl_lapu(istru-1,j)=tl_lapu(istru,j)
2474 END DO
2475 END IF
2476 IF (tl_lbc(iwest,isvbar,ng)%closed) THEN
2477 DO j=jstrvm1,jendp1
2478 lapv(istr-1,j)=gamma2(ng)*lapv(istr,j)
2479 tl_lapv(istr-1,j)=gamma2(ng)*tl_lapv(istr,j)
2480 END DO
2481 ELSE
2482 DO j=jstrvm1,jendp1
2483 lapv(istr-1,j)=0.0_r8
2484 tl_lapv(istr-1,j)=0.0_r8
2485 END DO
2486 END IF
2487 END IF
2488 END IF
2489!
2490 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2491 IF (domain(ng)%Eastern_Edge(tile)) THEN
2492 IF (tl_lbc(ieast,isubar,ng)%closed) THEN
2493 DO j=jstrm1,jendp1
2494 lapu(iend+1,j)=0.0_r8
2495 tl_lapu(iend+1,j)=0.0_r8
2496 END DO
2497 ELSE
2498 DO j=jstrm1,jendp1
2499 lapu(iend+1,j)=lapu(iend,j)
2500 tl_lapu(iend+1,j)=tl_lapu(iend,j)
2501 END DO
2502 END IF
2503 IF (tl_lbc(ieast,isvbar,ng)%closed) THEN
2504 DO j=jstrvm1,jendp1
2505 lapv(iend+1,j)=gamma2(ng)*lapv(iend,j)
2506 tl_lapv(iend+1,j)=gamma2(ng)*tl_lapv(iend,j)
2507 END DO
2508 ELSE
2509 DO j=jstrvm1,jendp1
2510 lapv(iend+1,j)=0.0_r8
2511 tl_lapv(iend+1,j)=0.0_r8
2512 END DO
2513 END IF
2514 END IF
2515 END IF
2516!
2517 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2518 IF (domain(ng)%Southern_Edge(tile)) THEN
2519 IF (tl_lbc(isouth,isubar,ng)%closed) THEN
2520 DO i=istrum1,iendp1
2521 lapu(i,jstr-1)=gamma2(ng)*lapu(i,jstr)
2522 tl_lapu(i,jstr-1)=gamma2(ng)*tl_lapu(i,jstr)
2523 END DO
2524 ELSE
2525 DO i=istrum1,iendp1
2526 lapu(i,jstr-1)=0.0_r8
2527 tl_lapu(i,jstr-1)=0.0_r8
2528 END DO
2529 END IF
2530 IF (tl_lbc(isouth,isvbar,ng)%closed) THEN
2531 DO i=istrm1,iendp1
2532 lapv(i,jstrv-1)=0.0_r8
2533 tl_lapv(i,jstrv-1)=0.0_r8
2534 END DO
2535 ELSE
2536 DO i=istrm1,iendp1
2537 lapv(i,jstrv-1)=lapv(i,jstrv)
2538 tl_lapv(i,jstrv-1)=tl_lapv(i,jstrv)
2539 END DO
2540 END IF
2541 END IF
2542 END IF
2543!
2544 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2545 IF (domain(ng)%Northern_Edge(tile)) THEN
2546 IF (tl_lbc(inorth,isubar,ng)%closed) THEN
2547 DO i=istrum1,iendp1
2548 lapu(i,jend+1)=gamma2(ng)*lapu(i,jend)
2549 tl_lapu(i,jend+1)=gamma2(ng)*tl_lapu(i,jend)
2550 END DO
2551 ELSE
2552 DO i=istrum1,iendp1
2553 lapu(i,jend+1)=0.0_r8
2554 tl_lapu(i,jend+1)=0.0_r8
2555 END DO
2556 END IF
2557 IF (tl_lbc(inorth,isvbar,ng)%closed) THEN
2558 DO i=istrm1,iendp1
2559 lapv(i,jend+1)=0.0_r8
2560 tl_lapv(i,jend+1)=0.0_r8
2561 END DO
2562 ELSE
2563 DO i=istrm1,iendp1
2564 lapv(i,jend+1)=lapv(i,jend)
2565 tl_lapv(i,jend+1)=tl_lapv(i,jend)
2566 END DO
2567 END IF
2568 END IF
2569 END IF
2570!
2571 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2572 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2573 IF (domain(ng)%SouthWest_Corner(tile)) THEN
2574 lapu(istr ,jstr-1)=0.5_r8*(lapu(istr+1,jstr-1)+ &
2575 & lapu(istr ,jstr ))
2576 tl_lapu(istr ,jstr-1)=0.5_r8*(tl_lapu(istr+1,jstr-1)+ &
2577 & tl_lapu(istr ,jstr ))
2578 lapv(istr-1,jstr )=0.5_r8*(lapv(istr-1,jstr+1)+ &
2579 & lapv(istr ,jstr ))
2580 tl_lapv(istr-1,jstr )=0.5_r8*(tl_lapv(istr-1,jstr+1)+ &
2581 & tl_lapv(istr ,jstr ))
2582 END IF
2583 END IF
2584
2585 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng).or. &
2586 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2587 IF (domain(ng)%SouthEast_Corner(tile)) THEN
2588 lapu(iend+1,jstr-1)=0.5_r8*(lapu(iend ,jstr-1)+ &
2589 & lapu(iend+1,jstr ))
2590 tl_lapu(iend+1,jstr-1)=0.5_r8*(tl_lapu(iend ,jstr-1)+ &
2591 & tl_lapu(iend+1,jstr ))
2592 lapv(iend+1,jstr )=0.5_r8*(lapv(iend ,jstr )+ &
2593 & lapv(iend+1,jstr+1))
2594 tl_lapv(iend+1,jstr )=0.5_r8*(tl_lapv(iend ,jstr )+ &
2595 & tl_lapv(iend+1,jstr+1))
2596 END IF
2597 END IF
2598
2599 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2600 & compositegrid(iwest ,ng).or.ewperiodic(ng))) THEN
2601 IF (domain(ng)%NorthWest_Corner(tile)) THEN
2602 lapu(istr ,jend+1)=0.5_r8*(lapu(istr+1,jend+1)+ &
2603 & lapu(istr ,jend ))
2604 tl_lapu(istr ,jend+1)=0.5_r8*(tl_lapu(istr+1,jend+1)+ &
2605 & tl_lapu(istr ,jend ))
2606 lapv(istr-1,jend+1)=0.5_r8*(lapv(istr ,jend+1)+ &
2607 & lapv(istr-1,jend ))
2608 tl_lapv(istr-1,jend+1)=0.5_r8*(tl_lapv(istr ,jend+1)+ &
2609 & tl_lapv(istr-1,jend ))
2610 END IF
2611 END IF
2612
2613 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng).or. &
2614 & compositegrid(ieast ,ng).or.ewperiodic(ng))) THEN
2615 IF (domain(ng)%NorthEast_Corner(tile)) THEN
2616 lapu(iend+1,jend+1)=0.5_r8*(lapu(iend ,jend+1)+ &
2617 & lapu(iend+1,jend ))
2618 tl_lapu(iend+1,jend+1)=0.5_r8*(tl_lapu(iend ,jend+1)+ &
2619 & tl_lapu(iend+1,jend ))
2620 lapv(iend+1,jend+1)=0.5_r8*(lapv(iend ,jend+1)+ &
2621 & lapv(iend+1,jend ))
2622 tl_lapv(iend+1,jend+1)=0.5_r8*(tl_lapv(iend ,jend+1)+ &
2623 & tl_lapv(iend+1,jend ))
2624 END IF
2625 END IF
2626!
2627! Compute flux-components of the horizontal divergence of the
2628! biharmonic stress tensor (m4/s2) in XI- and ETA-directions.
2629!
2630 DO j=jstrv-1,jend
2631 DO i=istru-1,iend
2632!^ cff=visc4_r(i,j)*Drhs(i,j)*0.5_r8* &
2633!^ & (pmon_r(i,j)* &
2634!^ & ((pn(i ,j)+pn(i+1,j))*LapU(i+1,j)- &
2635!^ & (pn(i-1,j)+pn(i ,j))*LapU(i ,j))- &
2636!^ & pnom_r(i,j)* &
2637!^ & ((pm(i,j )+pm(i,j+1))*LapV(i,j+1)- &
2638!^ & (pm(i,j-1)+pm(i,j ))*LapV(i,j )))
2639!^
2640 tl_cff=visc4_r(i,j)*0.5_r8* &
2641 & (tl_drhs(i,j)* &
2642 & (pmon_r(i,j)* &
2643 & ((pn(i ,j)+pn(i+1,j))*lapu(i+1,j)- &
2644 & (pn(i-1,j)+pn(i ,j))*lapu(i ,j))- &
2645 & pnom_r(i,j)* &
2646 & ((pm(i,j )+pm(i,j+1))*lapv(i,j+1)- &
2647 & (pm(i,j-1)+pm(i,j ))*lapv(i,j )))+ &
2648 & drhs(i,j)* &
2649 & (pmon_r(i,j)* &
2650 & ((pn(i ,j)+pn(i+1,j))*tl_lapu(i+1,j)- &
2651 & (pn(i-1,j)+pn(i ,j))*tl_lapu(i ,j))- &
2652 & pnom_r(i,j)* &
2653 & ((pm(i,j )+pm(i,j+1))*tl_lapv(i,j+1)- &
2654 & (pm(i,j-1)+pm(i,j ))*tl_lapv(i,j ))))
2655!^ UFx(i,j)=on_r(i,j)*on_r(i,j)*cff
2656!^
2657 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2658!^ VFe(i,j)=om_r(i,j)*om_r(i,j)*cff
2659!^
2660 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2661 END DO
2662 END DO
2663 DO j=jstr,jend+1
2664 DO i=istr,iend+1
2665!^ cff=visc4_p(i,j)*Drhs_p(i,j)*0.5_r8* &
2666!^ & (pmon_p(i,j)* &
2667!^ & ((pn(i ,j-1)+pn(i ,j))*LapV(i ,j)- &
2668!^ & (pn(i-1,j-1)+pn(i-1,j))*LapV(i-1,j))+ &
2669!^ & pnom_p(i,j)* &
2670!^ & ((pm(i-1,j )+pm(i,j ))*LapU(i,j )- &
2671!^ & (pm(i-1,j-1)+pm(i,j-1))*LapU(i,j-1)))
2672!^
2673 tl_cff=visc4_p(i,j)*0.5_r8* &
2674 & (tl_drhs_p(i,j)* &
2675 & (pmon_p(i,j)* &
2676 & ((pn(i ,j-1)+pn(i ,j))*lapv(i ,j)- &
2677 & (pn(i-1,j-1)+pn(i-1,j))*lapv(i-1,j))+ &
2678 & pnom_p(i,j)* &
2679 & ((pm(i-1,j )+pm(i,j ))*lapu(i,j )- &
2680 & (pm(i-1,j-1)+pm(i,j-1))*lapu(i,j-1)))+ &
2681 & drhs_p(i,j)* &
2682 & (pmon_p(i,j)* &
2683 & ((pn(i ,j-1)+pn(i ,j))*tl_lapv(i ,j)- &
2684 & (pn(i-1,j-1)+pn(i-1,j))*tl_lapv(i-1,j))+ &
2685 & pnom_p(i,j)* &
2686 & ((pm(i-1,j )+pm(i,j ))*tl_lapu(i,j )- &
2687 & (pm(i-1,j-1)+pm(i,j-1))*tl_lapu(i,j-1))))
2688# ifdef MASKING
2689!^ cff=cff*pmask(i,j)
2690!^
2691 tl_cff=tl_cff*pmask(i,j)
2692# endif
2693!^ UFe(i,j)=om_p(i,j)*om_p(i,j)*cff
2694!^
2695 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2696!^ VFx(i,j)=on_p(i,j)*on_p(i,j)*cff
2697!^
2698 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2699 END DO
2700 END DO
2701!
2702! Add in biharmonic viscosity.
2703!
2704 DO j=jstr,jend
2705 DO i=istru,iend
2706!^ cff1=0.5_r8*(pn(i-1,j)+pn(i,j))*(UFx(i,j )-UFx(i-1,j))
2707!^
2708 tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2709 & (tl_ufx(i,j )-tl_ufx(i-1,j))
2710!^ cff2=0.5_r8*(pm(i-1,j)+pm(i,j))*(UFe(i,j+1)-UFe(i ,j))
2711
2712 tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2713 & (ufe(i,j+1)-ufe(i ,j))
2714!^ fac=cff1+cff2
2715!^
2716 tl_fac=tl_cff1+tl_cff2
2717!^ rhs_ubar(i,j)=rhs_ubar(i,j)+fac
2718!^
2719 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_fac
2720# if defined DIAGNOSTICS_UV
2721!! DiaU2rhs(i,j,M2hvis)=fac
2722!! DiaU2rhs(i,j,M2xvis)=cff1
2723!! DiaU2rhs(i,j,M2yvis)=cff2
2724# endif
2725 END DO
2726 END DO
2727 DO j=jstrv,jend
2728 DO i=istr,iend
2729!^ cff1=0.5_r8*(pn(i,j-1)+pn(i,j))*(VFx(i+1,j)-VFx(i,j ))
2730!^
2731 tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2732 & (tl_vfx(i+1,j)-tl_vfx(i,j ))
2733!^ cff2=0.5_r8*(pm(i,j-1)+pm(i,j))*(VFe(i ,j)-VFe(i,j-1))
2734!^
2735 tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2736 & (tl_vfe(i ,j)-tl_vfe(i,j-1))
2737!^ fac=cff1-cff2
2738!^
2739 tl_fac=tl_cff1-tl_cff2
2740!^ rhs_vbar(i,j)=rhs_vbar(i,j)+fac
2741!^
2742 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_fac
2743# if defined DIAGNOSTICS_UV
2744!! DiaV2rhs(i,j,M2hvis)=fac
2745!! DiaV2rhs(i,j,M2xvis)= cff1
2746!! DiaV2rhs(i,j,M2yvis)=-cff2
2747# endif
2748 END DO
2749 END DO
2750#endif
2751#if defined WEC_MELLOR && \
2752 (!defined SOLVE3D || defined DIAGNOSTICS_UV)
2753!
2754!-----------------------------------------------------------------------
2755! Add in radiation stress terms.
2756!-----------------------------------------------------------------------
2757!
2758 DO j=jstr,jend
2759 DO i=istru,iend
2760!^ cff1=rustr2d(i,j)*om_u(i,j)*on_u(i,j)
2761!^
2762 tl_cff1=tl_rustr2d(i,j)*om_u(i,j)*on_u(i,j)
2763!^ cff2=rulag2d(i,j)
2764!^
2765 tl_cff2=tl_rulag2d(i,j)
2766# ifndef SOLVE3D
2767!^ rhs_ubar(i,j)=rhs_ubar(i,j)-cff1-cff2
2768!^
2769 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_cff1-tl_cff2
2770# endif
2771# ifdef DIAGNOSTICS_UV
2772!! DiaU2rhs(i,j,M2hrad)=-cff1
2773# endif
2774 END DO
2775 END DO
2776 DO j=jstrv,jend
2777 DO i=istr,iend
2778!^ cff1=rvstr2d(i,j)*om_v(i,j)*on_v(i,j)
2779!^
2780 tl_cff1=tl_rvstr2d(i,j)*om_v(i,j)*on_v(i,j)
2781!^ cff2=rvlag2d(i,j)
2782!^
2783 tl_cff2=tl_rvlag2d(i,j)
2784# ifndef SOLVE3D
2785!^ rhs_vbar(i,j)=rhs_vbar(i,j)-cff1-cff2
2786!^
2787 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_cff1-tl_cff2
2788# endif
2789# ifdef DIAGNOSTICS_UV
2790!! DiaV2rhs(i,j,M2hrad)=-cff1
2791# endif
2792 END DO
2793 END DO
2794#endif
2795#ifndef SOLVE3D
2796!
2797!-----------------------------------------------------------------------
2798! Add in bottom stress.
2799!-----------------------------------------------------------------------
2800!
2801 DO j=jstr,jend
2802 DO i=istru,iend
2803!^ fac=bustr(i,j)*om_u(i,j)*on_u(i,j)
2804!^
2805 tl_fac=tl_bustr(i,j)*om_u(i,j)*on_u(i,j)
2806!^ rhs_ubar(i,j)=rhs_ubar(i,j)-fac
2807!^
2808 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)-tl_fac
2809# ifdef DIAGNOSTICS_UV
2810!! DiaU2rhs(i,j,M2bstr)=-fac
2811# endif
2812 END DO
2813 END DO
2814 DO j=jstrv,jend
2815 DO i=istr,iend
2816!^ fac=bvstr(i,j)*om_v(i,j)*on_v(i,j)
2817!^
2818 tl_fac=tl_bvstr(i,j)*om_v(i,j)*on_v(i,j)
2819!^ rhs_vbar(i,j)=rhs_vbar(i,j)-fac
2820!^
2821 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)-tl_fac
2822# ifdef DIAGNOSTICS_UV
2823!! DiaV2rhs(i,j,M2bstr)=-fac
2824# endif
2825 END DO
2826 END DO
2827#else
2828# ifdef DIAGNOSTICS_UV
2829!!
2830!! Initialize the stress term if no bottom friction is defined.
2831!!
2832!! DO j=Jstr,Jend
2833!! DO i=IstrU,Iend
2834!! DiaU2rhs(i,j,M2bstr)=0.0_r8
2835!! END DO
2836!! END DO
2837!! DO j=JstrV,Jend
2838!! DO i=Istr,Iend
2839!! DiaV2rhs(i,j,M2bstr)=0.0_r8
2840!! END DO
2841!! END DO
2842# endif
2843#endif
2844!
2845!-----------------------------------------------------------------------
2846! Add in nudging of 2D momentum climatology.
2847!-----------------------------------------------------------------------
2848!
2849 IF (lnudgem2clm(ng)) THEN
2850 DO j=jstr,jend
2851 DO i=istru,iend
2852 cff=0.25_r8*(clima(ng)%M2nudgcof(i-1,j)+ &
2853 & clima(ng)%M2nudgcof(i ,j))* &
2854 & om_u(i,j)*on_u(i,j)
2855!^ rhs_ubar(i,j)=rhs_ubar(i,j)+ &
2856!^ & cff*(Drhs(i-1,j)+Drhs(i,j))* &
2857!^ & (CLIMA(ng)%ubarclm(i,j)- &
2858!^ & ubar(i,j,krhs))
2859!^
2860 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
2861 & cff*((drhs(i-1,j)+drhs(i,j))* &
2862 & (-tl_ubar(i,j,krhs))+ &
2863 & (tl_drhs(i-1,j)+tl_drhs(i,j))* &
2864 & (clima(ng)%ubarclm(i,j)- &
2865 & ubar(i,j,krhs)))
2866 END DO
2867 END DO
2868 DO j=jstrv,jend
2869 DO i=istr,iend
2870 cff=0.25_r8*(clima(ng)%M2nudgcof(i,j-1)+ &
2871 & clima(ng)%M2nudgcof(i,j ))* &
2872 & om_v(i,j)*on_v(i,j)
2873!^ rhs_vbar(i,j)=rhs_vbar(i,j)+ &
2874!^ & cff*(Drhs(i,j-1)+Drhs(i,j))* &
2875!^ & (CLIMA(ng)%vbarclm(i,j)- &
2876!^ & vbar(i,j,krhs))
2877!^
2878 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
2879 & cff*((drhs(i,j-1)+drhs(i,j))* &
2880 & (-tl_vbar(i,j,krhs))+ &
2881 & (tl_drhs(i,j-1)+tl_drhs(i,j))* &
2882 & (clima(ng)%vbarclm(i,j)- &
2883 & vbar(i,j,krhs)))
2884 END DO
2885 END DO
2886 END IF
2887
2888#ifdef SOLVE3D
2889!
2890!-----------------------------------------------------------------------
2891! Coupling between 2D and 3D equations.
2892!-----------------------------------------------------------------------
2893!
2894! Before the predictor step of the first barotropic time-step,
2895! arrays "rufrc" and "rvfrc" contain the vertical integrals of
2896! the 3D right-hand-side terms for momentum equations (including
2897! surface and bottom stresses, if so prescribed).
2898!
2899! Convert them into forcing terms by subtracting the fast time
2900! "rhs_ubar" and "rhs_vbar" from them; Also, immediately apply
2901! these forcing terms "rhs_ubar" and "rhs_vbar".
2902!
2903! From now on, these newly computed forcing terms will remain
2904! constant during the fast time stepping and will added to
2905! "rhs_ubar" and "rhs_vbar" during all subsequent time steps.
2906!
2907 IF (first_2d_step.and.predictor_2d_step(ng)) THEN
2908#if defined STOCHASTIC_OPT && !defined STOCH_OPT_WHITE
2909 IF (iic(ng).eq.ntfirst(ng).and.soinitial(ng)) THEN
2910#else
2911 IF (iic(ng).eq.ntfirst(ng)) THEN
2912#endif
2913 DO j=jstr,jend
2914 DO i=istru,iend
2915!^ rufrc(i,j)=rufrc(i,j)-rhs_ubar(i,j)
2916!^
2917 tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
2918!^ rhs_ubar(i,j)=rhs_ubar(i,j)+rufrc(i,j)
2919!^
2920 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_rufrc(i,j)
2921!^ ru(i,j,0,nstp)=rufrc(i,j)
2922!^
2923 tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
2924# ifdef DIAGNOSTICS_UV
2925!! DO idiag=1,M2pgrd
2926!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
2927!! & DiaU2rhs(i,j,idiag)
2928!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
2929!! & DiaRUfrc(i,j,3,idiag)
2930!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
2931!! END DO
2932!! DiaU2rhs(i,j,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
2933!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
2934!! DiaU2rhs(i,j,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
2935!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
2936# endif
2937 END DO
2938 END DO
2939 DO j=jstrv,jend
2940 DO i=istr,iend
2941!^ rvfrc(i,j)=rvfrc(i,j)-rhs_vbar(i,j)
2942!^
2943 tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
2944!^ rhs_vbar(i,j)=rhs_vbar(i,j)+rvfrc(i,j)
2945!^
2946 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_rvfrc(i,j)
2947!^ rv(i,j,0,nstp)=rvfrc(i,j)
2948!^
2949 tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
2950# ifdef DIAGNOSTICS_UV
2951!! DO idiag=1,M2pgrd
2952!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
2953!! & DiaV2rhs(i,j,idiag)
2954!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
2955!! & DiaRVfrc(i,j,3,idiag)
2956!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
2957!! END DO
2958!! DiaV2rhs(i,j,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
2959!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
2960!! DiaV2rhs(i,j,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
2961!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
2962# endif
2963 END DO
2964 END DO
2965#if defined STOCHASTIC_OPT && !defined STOCH_OPT_WHITE
2966 ELSE IF (iic(ng).eq.(ntfirst(ng)+1).and.soinitial(ng)) THEN
2967#else
2968 ELSE IF (iic(ng).eq.(ntfirst(ng)+1)) THEN
2969#endif
2970 DO j=jstr,jend
2971 DO i=istru,iend
2972!^ rufrc(i,j)=rufrc(i,j)-rhs_ubar(i,j)
2973!^
2974 tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
2975!^ rhs_ubar(i,j)=rhs_ubar(i,j)+ &
2976!^ & 1.5_r8*rufrc(i,j)-0.5_r8*ru(i,j,0,nnew)
2977!^
2978 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
2979 & 1.5_r8*tl_rufrc(i,j)- &
2980 & 0.5_r8*tl_ru(i,j,0,nnew)
2981!^ ru(i,j,0,nstp)=rufrc(i,j)
2982!^
2983 tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
2984# ifdef DIAGNOSTICS_UV
2985!! DO idiag=1,M2pgrd
2986!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
2987!! & DiaU2rhs(i,j,idiag)
2988!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
2989!! & 1.5_r8*DiaRUfrc(i,j,3,idiag)- &
2990!! & 0.5_r8*DiaRUfrc(i,j,nnew,idiag)
2991!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
2992!! END DO
2993!! DiaU2rhs(i,j,M2sstr)=1.5_r8*DiaRUfrc(i,j,3,M2sstr)- &
2994!! & 0.5_r8*DiaRUfrc(i,j,nnew,M2sstr)
2995!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
2996!! DiaU2rhs(i,j,M2bstr)=1.5_r8*DiaRUfrc(i,j,3,M2bstr)- &
2997!! & 0.5_r8*DiaRUfrc(i,j,nnew,M2bstr)
2998!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
2999# endif
3000 END DO
3001 END DO
3002 DO j=jstrv,jend
3003 DO i=istr,iend
3004!^ rvfrc(i,j)=rvfrc(i,j)-rhs_vbar(i,j)
3005!^
3006 tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
3007!^ rhs_vbar(i,j)=rhs_vbar(i,j)+ &
3008!^ & 1.5_r8*rvfrc(i,j)-0.5_r8*rv(i,j,0,nnew)
3009!^
3010 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
3011 & 1.5_r8*tl_rvfrc(i,j)- &
3012 & 0.5_r8*tl_rv(i,j,0,nnew)
3013!^ rv(i,j,0,nstp)=rvfrc(i,j)
3014!^
3015 tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
3016# ifdef DIAGNOSTICS_UV
3017!! DO idiag=1,M2pgrd
3018!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
3019!! & DiaV2rhs(i,j,idiag)
3020!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
3021!! & 1.5_r8*DiaRVfrc(i,j,3,idiag)- &
3022!! & 0.5_r8*DiaRVfrc(i,j,nnew,idiag)
3023!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
3024!! END DO
3025!! DiaV2rhs(i,j,M2sstr)=1.5_r8*DiaRVfrc(i,j,3,M2sstr)- &
3026!! & 0.5_r8*DiaRVfrc(i,j,nnew,M2sstr)
3027!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
3028!! DiaV2rhs(i,j,M2bstr)=1.5_r8*DiaRVfrc(i,j,3,M2bstr)- &
3029!! & 0.5_r8*DiaRVfrc(i,j,nnew,M2bstr)
3030!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
3031# endif
3032 END DO
3033 END DO
3034 ELSE
3035 cff1=23.0_r8/12.0_r8
3036 cff2=16.0_r8/12.0_r8
3037 cff3= 5.0_r8/12.0_r8
3038 DO j=jstr,jend
3039 DO i=istru,iend
3040!^ rufrc(i,j)=rufrc(i,j)-rhs_ubar(i,j)
3041!^
3042 tl_rufrc(i,j)=tl_rufrc(i,j)-tl_rhs_ubar(i,j)
3043!^ rhs_ubar(i,j)=rhs_ubar(i,j)+ &
3044!^ & cff1*rufrc(i,j)- &
3045!^ & cff2*ru(i,j,0,nnew)+ &
3046!^ & cff3*ru(i,j,0,nstp)
3047!^
3048 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+ &
3049 & cff1*tl_rufrc(i,j)- &
3050 & cff2*tl_ru(i,j,0,nnew)+ &
3051 & cff3*tl_ru(i,j,0,nstp)
3052!^ ru(i,j,0,nstp)=rufrc(i,j)
3053!^
3054 tl_ru(i,j,0,nstp)=tl_rufrc(i,j)
3055# ifdef DIAGNOSTICS_UV
3056!! DO idiag=1,M2pgrd
3057!! DiaRUfrc(i,j,3,idiag)=DiaRUfrc(i,j,3,idiag)- &
3058!! & DiaU2rhs(i,j,idiag)
3059!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
3060!! & cff1*DiaRUfrc(i,j,3,idiag)- &
3061!! & cff2*DiaRUfrc(i,j,nnew,idiag)+ &
3062!! & cff3*DiaRUfrc(i,j,nstp,idiag)
3063!! DiaRUfrc(i,j,nstp,idiag)=DiaRUfrc(i,j,3,idiag)
3064!! END DO
3065!! DiaU2rhs(i,j,M2sstr)=cff1*DiaRUfrc(i,j,3,M2sstr)- &
3066!! & cff2*DiaRUfrc(i,j,nnew,M2sstr)+ &
3067!! & cff3*DiaRUfrc(i,j,nstp,M2sstr)
3068!! DiaRUfrc(i,j,nstp,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
3069!! DiaU2rhs(i,j,M2bstr)=cff1*DiaRUfrc(i,j,3,M2bstr)- &
3070!! & cff2*DiaRUfrc(i,j,nnew,M2bstr)+ &
3071!! & cff3*DiaRUfrc(i,j,nstp,M2bstr)
3072!! DiaRUfrc(i,j,nstp,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
3073# endif
3074 END DO
3075 END DO
3076 DO j=jstrv,jend
3077 DO i=istr,iend
3078!^ rvfrc(i,j)=rvfrc(i,j)-rhs_vbar(i,j)
3079!^
3080 tl_rvfrc(i,j)=tl_rvfrc(i,j)-tl_rhs_vbar(i,j)
3081!^ rhs_vbar(i,j)=rhs_vbar(i,j)+ &
3082!^ & cff1*rvfrc(i,j)- &
3083!^ & cff2*rv(i,j,0,nnew)+ &
3084!^ & cff3*rv(i,j,0,nstp)
3085!^
3086 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+ &
3087 & cff1*tl_rvfrc(i,j)- &
3088 & cff2*tl_rv(i,j,0,nnew)+ &
3089 & cff3*tl_rv(i,j,0,nstp)
3090!^ rv(i,j,0,nstp)=rvfrc(i,j)
3091!^
3092 tl_rv(i,j,0,nstp)=tl_rvfrc(i,j)
3093# ifdef DIAGNOSTICS_UV
3094!! DO idiag=1,M2pgrd
3095!! DiaRVfrc(i,j,3,idiag)=DiaRVfrc(i,j,3,idiag)- &
3096!! & DiaV2rhs(i,j,idiag)
3097!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
3098!! & cff1*DiaRVfrc(i,j,3,idiag)- &
3099!! & cff2*DiaRVfrc(i,j,nnew,idiag)+ &
3100!! & cff3*DiaRVfrc(i,j,nstp,idiag)
3101!! DiaRVfrc(i,j,nstp,idiag)=DiaRVfrc(i,j,3,idiag)
3102!! END DO
3103!! DiaV2rhs(i,j,M2sstr)=cff1*DiaRVfrc(i,j,3,M2sstr)- &
3104!! & cff2*DiaRVfrc(i,j,nnew,M2sstr)+ &
3105!! & cff3*DiaRVfrc(i,j,nstp,M2sstr)
3106!! DiaRVfrc(i,j,nstp,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
3107!! DiaV2rhs(i,j,M2bstr)=cff1*DiaRVfrc(i,j,3,M2bstr)- &
3108!! & cff2*DiaRVfrc(i,j,nnew,M2bstr)+ &
3109!! & cff3*DiaRVfrc(i,j,nstp,M2bstr)
3110!! DiaRVfrc(i,j,nstp,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
3111# endif
3112 END DO
3113 END DO
3114 END IF
3115 ELSE
3116 DO j=jstr,jend
3117 DO i=istru,iend
3118!^ rhs_ubar(i,j)=rhs_ubar(i,j)+rufrc(i,j)
3119!^
3120 tl_rhs_ubar(i,j)=tl_rhs_ubar(i,j)+tl_rufrc(i,j)
3121# ifdef DIAGNOSTICS_UV
3122!! DO idiag=1,M2pgrd
3123!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)+ &
3124!! & DiaRUfrc(i,j,3,idiag)
3125!! END DO
3126!! DiaU2rhs(i,j,M2sstr)=DiaRUfrc(i,j,3,M2sstr)
3127!! DiaU2rhs(i,j,M2bstr)=DiaRUfrc(i,j,3,M2bstr)
3128# endif
3129 END DO
3130 END DO
3131 DO j=jstrv,jend
3132 DO i=istr,iend
3133!^ rhs_vbar(i,j)=rhs_vbar(i,j)+rvfrc(i,j)
3134!^
3135 tl_rhs_vbar(i,j)=tl_rhs_vbar(i,j)+tl_rvfrc(i,j)
3136# ifdef DIAGNOSTICS_UV
3137!! DO idiag=1,M2pgrd
3138!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)+ &
3139!! & DiaRVfrc(i,j,3,idiag)
3140!! END DO
3141!! DiaV2rhs(i,j,M2sstr)=DiaRVfrc(i,j,3,M2sstr)
3142!! DiaV2rhs(i,j,M2bstr)=DiaRVfrc(i,j,3,M2bstr)
3143# endif
3144 END DO
3145 END DO
3146 END IF
3147#else
3148!^
3149!^----------------------------------------------------------------------
3150!^ Add in surface momentum stress.
3151!^----------------------------------------------------------------------
3152!^
3153!^ DO j=Jstr,Jend
3154!^ DO i=IstrU,Iend
3155!^ fac=sustr(i,j)*om_u(i,j)*on_u(i,j)
3156!^ rhs_ubar(i,j)=rhs_ubar(i,j)+fac
3157# ifdef DIAGNOSTICS_UV
3158!! DiaU2rhs(i,j,M2sstr)=fac
3159# endif
3160!^ END DO
3161!^ END DO
3162!^ DO j=JstrV,Jend
3163!^ DO i=Istr,Iend
3164!^ fac=svstr(i,j)*om_v(i,j)*on_v(i,j)
3165!^ rhs_vbar(i,j)=rhs_vbar(i,j)+fac
3166# ifdef DIAGNOSTICS_UV
3167!! DiaV2rhs(i,j,M2sstr)=fac
3168# endif
3169!^ END DO
3170!^ END DO
3171#endif
3172!
3173!=======================================================================
3174! Time step 2D momentum equations.
3175!=======================================================================
3176!
3177! Compute total water column depth.
3178!
3179 DO j=jstrv-1,jend
3180 DO i=istru-1,iend
3181 dstp(i,j)=zeta(i,j,kstp)+h(i,j)
3182 tl_dstp(i,j)=tl_zeta(i,j,kstp)+tl_h(i,j)
3183 END DO
3184 END DO
3185!
3186! During the first time-step, the predictor step is Forward-Euler
3187! and the corrector step is Backward-Euler. Otherwise, the predictor
3188! step is Leap-frog and the corrector step is Adams-Moulton.
3189#ifdef WET_DRY_NOT_YET
3190! HGA: We need to think more about TLM of the wet/dry mask arrays
3191! since they are time-dependent.
3192#endif
3193!
3194#if defined STOCHASTIC_OPT && !defined STOCH_OPT_WHITE && \
3195 !defined SOLVE3D
3196 IF (first_2d_step.and.soinitial(ng)) THEN
3197#else
3198 IF (first_2d_step) THEN
3199#endif
3200 cff1=0.5_r8*dtfast(ng)
3201#ifdef WET_DRY_NOT_YET
3202 cff2=1.0_r8/cff1
3203#endif
3204 DO j=jstr,jend
3205 DO i=istru,iend
3206 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
3207 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
3208 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i-1,j))
3209!^ ubar(i,j,knew)=(ubar(i,j,kstp)* &
3210!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
3211!^ & cff*cff1*rhs_ubar(i,j))*fac
3212!^
3213 tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
3214 & (dstp(i,j)+dstp(i-1,j))+ &
3215 & ubar(i,j,kstp)* &
3216 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
3217 & cff*cff1*tl_rhs_ubar(i,j))*fac+ &
3218 & (ubar(i,j,kstp)* &
3219 & (dstp(i,j)+dstp(i-1,j))+ &
3220 & cff*cff1*rhs_ubar(i,j))*tl_fac
3221#ifdef MASKING
3222!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
3223!^
3224 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
3225#endif
3226#ifdef WET_DRY_NOT_YET
3227!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
3228!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
3229!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3230!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
3231!^
3232!^ HGA: TLM code needed here.
3233!^
3234 fac1=cff2/cff
3235!^ rhs_ubar(i,j)=(ubar(i,j,knew)*(Dnew(i,j)+Dnew(i-1,j))- &
3236!^ & ubar(i,j,kstp)*(Dstp(i,j)+Dstp(i-1,j)))* &
3237!^ & fac1
3238!^
3239 tl_rhs_ubar(i,j)=(tl_ubar(i,j,knew)* &
3240 & (dnew(i,j)+dnew(i-1,j))+ &
3241 & ubar(i,j,knew)* &
3242 & (tl_dnew(i,j)+tl_dnew(i-1,j))- &
3243 & tl_ubar(i,j,kstp)* &
3244 & (dstp(i,j)+dstp(i-1,j))- &
3245 & ubar(i,j,kstp)* &
3246 & (tl_dstp(i,j)+tl_dstp(i-1,j)))*fac1
3247#endif
3248 END DO
3249 END DO
3250 DO j=jstrv,jend
3251 DO i=istr,iend
3252 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3253 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
3254 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i,j-1))
3255!^ vbar(i,j,knew)=(vbar(i,j,kstp)* &
3256!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
3257!^ & cff*cff1*rhs_vbar(i,j))*fac
3258!^
3259 tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
3260 & (dstp(i,j)+dstp(i,j-1))+ &
3261 & vbar(i,j,kstp)* &
3262 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
3263 & cff*cff1*tl_rhs_vbar(i,j))*fac+ &
3264 & (vbar(i,j,kstp)* &
3265 & (dstp(i,j)+dstp(i,j-1))+ &
3266 & cff*cff1*rhs_vbar(i,j))*tl_fac
3267#ifdef MASKING
3268!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
3269!^
3270 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
3271#endif
3272#ifdef WET_DRY_NOT_YET
3273!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
3274!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
3275!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3276!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
3277!^
3278!^ HGA: TLM code needed here.
3279!^
3280 fac1=cff2/cff
3281!^ rhs_vbar(i,j)=(vbar(i,j,knew)*(Dnew(i,j)+Dnew(i,j-1))- &
3282!^ & vbar(i,j,kstp)*(Dstp(i,j)+Dstp(i,j-1)))* &
3283!^ & fac1
3284!^
3285 tl_rhs_vbar(i,j)=(tl_vbar(i,j,knew)* &
3286 & (dnew(i,j)+dnew(i,j-1))+ &
3287 & vbar(i,j,knew)* &
3288 & (tl_dnew(i,j)+tl_dnew(i,j-1))- &
3289 & tl_vbar(i,j,kstp)* &
3290 & (dstp(i,j)+dstp(i,j-1))- &
3291 & vbar(i,j,kstp)* &
3292 & (tl_dstp(i,j)+tl_dstp(i,j-1)))*fac1
3293#endif
3294 END DO
3295 END DO
3296 ELSE IF (predictor_2d_step(ng)) THEN
3297 cff1=dtfast(ng)
3298#ifdef WET_DRY_NOT_YET
3299 cff2=1.0_r8/cff1
3300#endif
3301 DO j=jstr,jend
3302 DO i=istru,iend
3303 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
3304 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
3305 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i-1,j))
3306!^ ubar(i,j,knew)=(ubar(i,j,kstp)* &
3307!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
3308!^ & cff*cff1*rhs_ubar(i,j))*fac
3309!^
3310 tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
3311 & (dstp(i,j)+dstp(i-1,j))+ &
3312 & ubar(i,j,kstp)* &
3313 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
3314 & cff*cff1*tl_rhs_ubar(i,j))*fac+ &
3315 & (ubar(i,j,kstp)* &
3316 & (dstp(i,j)+dstp(i-1,j))+ &
3317 & cff*cff1*rhs_ubar(i,j))*tl_fac
3318#ifdef MASKING
3319!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
3320!^
3321 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
3322#endif
3323#ifdef WET_DRY_NOT_YET
3324!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
3325!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
3326!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3327!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
3328!^
3329!^ HGA: TLM code needed here.
3330!^
3331 fac1=cff2/cff
3332!^ rhs_ubar(i,j)=(ubar(i,j,knew)*(Dnew(i,j)+Dnew(i-1,j))- &
3333!^ & ubar(i,j,kstp)*(Dstp(i,j)+Dstp(i-1,j)))* &
3334!^ & fac1
3335!^
3336 tl_rhs_ubar(i,j)=(tl_ubar(i,j,knew)* &
3337 & (dnew(i,j)+dnew(i-1,j))+ &
3338 & ubar(i,j,knew)* &
3339 & (tl_dnew(i,j)+tl_dnew(i-1,j))- &
3340 & tl_ubar(i,j,kstp)* &
3341 & (dstp(i,j)+dstp(i-1,j))- &
3342 & ubar(i,j,kstp)* &
3343 & (tl_dstp(i,j)+tl_dstp(i-1,j)))*fac1
3344#endif
3345 END DO
3346 END DO
3347 DO j=jstrv,jend
3348 DO i=istr,iend
3349 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3350 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
3351 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i,j-1))
3352!^ vbar(i,j,knew)=(vbar(i,j,kstp)* &
3353!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
3354!^ & cff*cff1*rhs_vbar(i,j))*fac
3355!^
3356 tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
3357 & (dstp(i,j)+dstp(i,j-1))+ &
3358 & vbar(i,j,kstp)* &
3359 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
3360 & cff*cff1*tl_rhs_vbar(i,j))*fac+ &
3361 & (vbar(i,j,kstp)* &
3362 & (dstp(i,j)+dstp(i,j-1))+ &
3363 & cff*cff1*rhs_vbar(i,j))*tl_fac
3364#ifdef MASKING
3365!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
3366!^
3367 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
3368#endif
3369#ifdef WET_DRY_NOT_YET
3370!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
3371!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
3372!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3373!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
3374!^
3375!^ HGA: TLM code needed here.
3376!^
3377 fac1=cff2/cff
3378!^ rhs_vbar(i,j)=(vbar(i,j,knew)*(Dnew(i,j)+Dnew(i,j-1))- &
3379!^ & vbar(i,j,kstp)*(Dstp(i,j)+Dstp(i,j-1)))* &
3380!^ & fac1
3381!^
3382 tl_rhs_vbar(i,j)=(tl_vbar(i,j,knew)* &
3383 & (dnew(i,j)+dnew(i,j-1))+ &
3384 & vbar(i,j,knew)* &
3385 & (tl_dnew(i,j)+tl_dnew(i,j-1))- &
3386 & tl_vbar(i,j,kstp)* &
3387 & (dstp(i,j)+dstp(i,j-1))- &
3388 & vbar(i,j,kstp)* &
3389 & (tl_dstp(i,j)+tl_dstp(i,j-1)))*fac1
3390#endif
3391 END DO
3392 END DO
3393 ELSE IF (corrector_2d_step) THEN
3394 cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
3395 cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
3396 cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
3397#ifdef WET_DRY_NOT_YET
3398 cff4=1.0_r8/cff1
3399#endif
3400 DO j=jstr,jend
3401 DO i=istru,iend
3402 cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
3403 fac=1.0_r8/(dnew(i,j)+dnew(i-1,j))
3404 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i-1,j))
3405!^ ubar(i,j,knew)=(ubar(i,j,kstp)* &
3406!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
3407!^ & cff*(cff1*rhs_ubar(i,j)+ &
3408!^ & cff2*rubar(i,j,kstp)- &
3409!^ & cff3*rubar(i,j,ptsk)))*fac
3410!^
3411 tl_ubar(i,j,knew)=(tl_ubar(i,j,kstp)* &
3412 & (dstp(i,j)+dstp(i-1,j))+ &
3413 & ubar(i,j,kstp)* &
3414 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
3415 & cff*(cff1*tl_rhs_ubar(i,j)+ &
3416 & cff2*tl_rubar(i,j,kstp)- &
3417 & cff3*tl_rubar(i,j,ptsk)))*fac+ &
3418 & (ubar(i,j,kstp)* &
3419 & (dstp(i,j)+dstp(i-1,j))+ &
3420 & cff*(cff1*rhs_ubar(i,j)+ &
3421 & cff2*rubar(i,j,kstp)- &
3422 & cff3*rubar(i,j,ptsk)))*tl_fac
3423#ifdef MASKING
3424!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
3425!^
3426 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
3427#endif
3428#ifdef WET_DRY_NOT_YET
3429!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
3430!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
3431!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3432!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
3433!^
3434!^ HGA: TLM code needed here.
3435!^
3436 fac1=1.0_r8/cff
3437!^ rhs_ubar(i,j)=((ubar(i,j,knew)*(Dnew(i,j)+Dnew(i-1,j))- &
3438!^ & ubar(i,j,kstp)*(Dstp(i,j)+Dstp(i-1,j)))* &
3439!^ & fac1- &
3440!^ & cff2*rubar(i,j,kstp)+ &
3441!^ & cff3*rubar(i,j,ptsk))*cff4
3442!^
3443 tl_rhs_ubar(i,j)=((tl_ubar(i,j,knew)* &
3444 & (dnew(i,j)+dnew(i-1,j))+ &
3445 & ubar(i,j,knew)* &
3446 & (tl_dnew(i,j)+tl_dnew(i-1,j))- &
3447 & tl_ubar(i,j,kstp)* &
3448 & (dstp(i,j)+dstp(i-1,j))- &
3449 & ubar(i,j,kstp)* &
3450 & (tl_dstp(i,j)+tl_dstp(i-1,j)))*fac1- &
3451 & cff2*tl_rubar(i,j,kstp)+ &
3452 & cff3*tl_rubar(i,j,ptsk))*cff4
3453#endif
3454 END DO
3455 END DO
3456 DO j=jstrv,jend
3457 DO i=istr,iend
3458 cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3459 fac=1.0_r8/(dnew(i,j)+dnew(i,j-1))
3460 tl_fac=-fac*fac*(tl_dnew(i,j)+tl_dnew(i,j-1))
3461!^ vbar(i,j,knew)=(vbar(i,j,kstp)* &
3462!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
3463!^ & cff*(cff1*rhs_vbar(i,j)+ &
3464!^ & cff2*rvbar(i,j,kstp)- &
3465!^ & cff3*rvbar(i,j,ptsk)))*fac
3466!^
3467 tl_vbar(i,j,knew)=(tl_vbar(i,j,kstp)* &
3468 & (dstp(i,j)+dstp(i,j-1))+ &
3469 & vbar(i,j,kstp)* &
3470 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
3471 & cff*(cff1*tl_rhs_vbar(i,j)+ &
3472 & cff2*tl_rvbar(i,j,kstp)- &
3473 & cff3*tl_rvbar(i,j,ptsk)))*fac+ &
3474 & (vbar(i,j,kstp)* &
3475 & (dstp(i,j)+dstp(i,j-1))+ &
3476 & cff*(cff1*rhs_vbar(i,j)+ &
3477 & cff2*rvbar(i,j,kstp)- &
3478 & cff3*rvbar(i,j,ptsk)))*tl_fac
3479#ifdef MASKING
3480!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
3481!^
3482 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
3483#endif
3484#ifdef WET_DRY_NOT_YET
3485!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
3486!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
3487!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3488!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
3489!^
3490!^ HGA: TLM code needed here.
3491!^
3492 fac1=1.0_r8/cff
3493!^ rhs_vbar(i,j)=((vbar(i,j,knew)*(Dnew(i,j)+Dnew(i,j-1))- &
3494!^ & vbar(i,j,kstp)*(Dstp(i,j)+Dstp(i,j-1)))* &
3495!^ & fac1- &
3496!^ & cff2*rvbar(i,j,kstp)+ &
3497!^ & cff3*rvbar(i,j,ptsk))*cff4
3498!^
3499 tl_rhs_vbar(i,j)=((tl_vbar(i,j,knew)* &
3500 & (dnew(i,j)+dnew(i,j-1))+ &
3501 & vbar(i,j,knew)* &
3502 & (tl_dnew(i,j)+tl_dnew(i,j-1))- &
3503 & tl_vbar(i,j,kstp)* &
3504 & (dstp(i,j)+dstp(i,j-1))- &
3505 & vbar(i,j,kstp)* &
3506 & (tl_dstp(i,j)+tl_dstp(i,j-1)))*fac1- &
3507 & cff2*tl_rvbar(i,j,kstp)+ &
3508 & cff3*tl_rvbar(i,j,ptsk))*cff4
3509#endif
3510 END DO
3511 END DO
3512 END IF
3513#ifdef DIAGNOSTICS_UV
3514!!
3515!!-----------------------------------------------------------------------
3516!! Time step 2D momentum diagnostic terms.
3517!!-----------------------------------------------------------------------
3518
3519# ifdef MASKING
3520!!
3521!! Apply land/sea mask.
3522!!
3523!! DO idiag=1,NDM2d-1
3524!! DO j=Jstr,Jend
3525!! DO i=IstrU,Iend
3526!! DiaU2rhs(i,j,idiag)=DiaU2rhs(i,j,idiag)*umask(i,j)
3527!! END DO
3528!! END DO
3529!! DO j=JstrV,Jend
3530!! DO i=Istr,Iend
3531!! DiaV2rhs(i,j,idiag)=DiaV2rhs(i,j,idiag)*vmask(i,j)
3532!! END DO
3533!! END DO
3534!! END DO
3535# endif
3536# ifdef SOLVE3D
3537!!
3538!! The arrays "DiaU2rhs" and "DiaV2rhs" contain the contributions of
3539!! each of the 2D right-hand-side terms for the momentum equations.
3540!!
3541!! These values are integrated, time-stepped and converted to mass flux
3542!! units (m3 s-1) for coupling with the 3D diagnostic terms.
3543!!
3544!! fac=weight(1,iif(ng),ng)
3545!! IF (FIRST_2D_STEP.and.CORRECTOR_2D_STEP) THEN
3546!! cff1=0.5_r8*dtfast(ng)
3547!! DO idiag=1,NDM2d-1
3548!! DO j=Jstr,Jend
3549!! DO i=IstrU,Iend
3550!! DiaU2int(i,j,idiag)=cff1*DiaU2rhs(i,j,idiag)
3551!! DiaU2wrk(i,j,idiag)=DiaU2int(i,j,idiag)* &
3552!! & (pm(i-1,j)+pm(i,j))*fac
3553!! END DO
3554!! END DO
3555!! DO j=JstrV,Jend
3556!! DO i=Istr,Iend
3557!! DiaV2int(i,j,idiag)=cff1*DiaV2rhs(i,j,idiag)
3558!! DiaV2wrk(i,j,idiag)=DiaV2int(i,j,idiag)* &
3559!! & (pn(i,j)+pn(i,j-1))*fac
3560!! END DO
3561!! END DO
3562!! END DO
3563!! ELSE IF (CORRECTOR_2D_STEP) THEN
3564!! cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
3565!! cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
3566!! cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
3567!! DO idiag=1,NDM2d-1
3568!! DO j=Jstr,Jend
3569!! DO i=IstrU,Iend
3570!! DiaU2int(i,j,idiag)=DiaU2int(i,j,idiag)+ &
3571!! & (cff1*DiaU2rhs(i,j,idiag)+ &
3572!! & cff2*DiaRUbar(i,j,kstp,idiag)- &
3573!! & cff3*DiaRUbar(i,j,ptsk,idiag))
3574!! DiaU2wrk(i,j,idiag)=DiaU2wrk(i,j,idiag)+ &
3575!! & DiaU2int(i,j,idiag)* &
3576!! & (pm(i-1,j)+pm(i,j))*fac
3577!! END DO
3578!! END DO
3579!! DO j=JstrV,Jend
3580!! DO i=Istr,Iend
3581!! DiaV2int(i,j,idiag)=DiaV2int(i,j,idiag)+ &
3582!! & (cff1*DiaV2rhs(i,j,idiag)+ &
3583!! & cff2*DiaRVbar(i,j,kstp,idiag)- &
3584!! & cff3*DiaRVbar(i,j,ptsk,idiag))
3585!! DiaV2wrk(i,j,idiag)=DiaV2wrk(i,j,idiag)+ &
3586!! & DiaV2int(i,j,idiag)* &
3587!! & (pn(i,j)+pn(i,j-1))*fac
3588!! END DO
3589!! END DO
3590!! END DO
3591!! END IF
3592# else
3593!!
3594!! Time-step the diagnostic terms.
3595!!
3596!! IF (FIRST_2D_STEP.and.CORRECTOR_2D_STEP) THEN
3597!! cff1=0.5_r8*dtfast(ng)
3598!! DO idiag=1,NDM2d-1
3599!! DO j=Jstr,Jend
3600!! DO i=IstrU,Iend
3601!! cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
3602!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
3603!! DiaU2wrk(i,j,idiag)=cff*cff1*DiaU2rhs(i,j,idiag)*fac
3604!! END DO
3605!! END DO
3606!! DO j=JstrV,Jend
3607!! DO i=Istr,Iend
3608!! cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3609!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
3610!! DiaV2wrk(i,j,idiag)=cff*cff1*DiaV2rhs(i,j,idiag)*fac
3611!! END DO
3612!! END DO
3613!! END DO
3614!! DO j=Jstr,Jend
3615!! DO i=IstrU,Iend
3616!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
3617!! DiaU2wrk(i,j,M2rate)=ubar(i,j,knew)-ubar(i,j,kstp)* &
3618!! & (Dstp(i,j)+Dstp(i-1,j))*fac
3619!! END DO
3620!! END DO
3621!! DO j=JstrV,Jend
3622!! DO i=Istr,Iend
3623!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
3624!! DiaV2wrk(i,j,M2rate)=vbar(i,j,knew)-vbar(i,j,kstp)* &
3625!! & (Dstp(i,j)+Dstp(i,j-1))*fac
3626!! END DO
3627!! END DO
3628!! ELSE IF (CORRECTOR_2D_STEP) THEN
3629!! cff1=0.5_r8*dtfast(ng)*5.0_r8/12.0_r8
3630!! cff2=0.5_r8*dtfast(ng)*8.0_r8/12.0_r8
3631!! cff3=0.5_r8*dtfast(ng)*1.0_r8/12.0_r8
3632!! DO idiag=1,NDM2d-1
3633!! DO j=Jstr,Jend
3634!! DO i=IstrU,Iend
3635!! cff=(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
3636!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
3637!! DiaU2wrk(i,j,idiag)=cff*(cff1*DiaU2rhs(i,j,idiag)+ &
3638!! & cff2*DiaRUbar(i,j,kstp,idiag)- &
3639!! & cff3*DiaRUbar(i,j,ptsk,idiag))* &
3640!! & fac
3641!! END DO
3642!! END DO
3643!! DO j=JstrV,Jend
3644!! DO i=Istr,Iend
3645!! cff=(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3646!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
3647!! DiaV2wrk(i,j,idiag)=cff*(cff1*DiaV2rhs(i,j,idiag)+ &
3648!! & cff2*DiaRVbar(i,j,kstp,idiag)- &
3649!! & cff3*DiaRVbar(i,j,ptsk,idiag))*
3650!! & fac
3651!! END DO
3652!! END DO
3653!! END DO
3654!! DO j=Jstr,Jend
3655!! DO i=IstrU,Iend
3656!! fac=1.0_r8/(Dnew(i,j)+Dnew(i-1,j))
3657!! DiaU2wrk(i,j,M2rate)=ubar(i,j,knew)- &
3658!! & ubar(i,j,kstp)* &
3659!! & (Dstp(i,j)+Dstp(i-1,j))*fac
3660!! END DO
3661!! END DO
3662!! DO j=JstrV,Jend
3663!! DO i=Istr,Iend
3664!! fac=1.0_r8/(Dnew(i,j)+Dnew(i,j-1))
3665!! DiaV2wrk(i,j,M2rate)=vbar(i,j,knew)- &
3666!! & vbar(i,j,kstp)* &
3667!! & (Dstp(i,j)+Dstp(i,j-1))*fac
3668!! END DO
3669!! END DO
3670!! END IF
3671# endif
3672#endif
3673!
3674! If predictor step, load right-side-term into shared arrays for
3675! future use during the subsequent corrector step.
3676!
3677 IF (predictor_2d_step(ng)) THEN
3678 DO j=jstr,jend
3679 DO i=istru,iend
3680!^ rubar(i,j,krhs)=rhs_ubar(i,j)
3681!^
3682 tl_rubar(i,j,krhs)=tl_rhs_ubar(i,j)
3683 END DO
3684 END DO
3685 DO j=jstrv,jend
3686 DO i=istr,iend
3687!^ rvbar(i,j,krhs)=rhs_vbar(i,j)
3688!^
3689 tl_rvbar(i,j,krhs)=tl_rhs_vbar(i,j)
3690 END DO
3691 END DO
3692#ifdef DIAGNOSTICS_UV
3693!! DO idiag=1,NDM2d-1
3694!! DO j=Jstr,Jend
3695!! DO i=IstrU,Iend
3696!! DiaRUbar(i,j,krhs,idiag)=DiaU2rhs(i,j,idiag)
3697!! END DO
3698!! END DO
3699!! DO j=JstrV,Jend
3700!! DO i=Istr,Iend
3701!! DiaRVbar(i,j,krhs,idiag)=DiaV2rhs(i,j,idiag)
3702!! END DO
3703!! END DO
3704!! END DO
3705#endif
3706 END IF
3707!
3708!-----------------------------------------------------------------------
3709! Apply lateral boundary conditions.
3710!-----------------------------------------------------------------------
3711!
3712!^ CALL u2dbc_tile (ng, tile, &
3713!^ & LBi, UBi, LBj, UBj, &
3714!^ & IminS, ImaxS, JminS, JmaxS, &
3715!^ & krhs, kstp, knew, &
3716!^ & ubar, vbar, zeta)
3717!^
3718 CALL tl_u2dbc_tile (ng, tile, &
3719 & lbi, ubi, lbj, ubj, &
3720 & imins, imaxs, jmins, jmaxs, &
3721 & krhs, kstp, knew, &
3722 & ubar, vbar, zeta, &
3723 & tl_ubar, tl_vbar, tl_zeta)
3724!^ CALL v2dbc_tile (ng, tile, &
3725!^ & LBi, UBi, LBj, UBj, &
3726!^ & IminS, ImaxS, JminS, JmaxS, &
3727!^ & krhs, kstp, knew, &
3728!^ & ubar, vbar, zeta)
3729!^
3730 CALL tl_v2dbc_tile (ng, tile, &
3731 & lbi, ubi, lbj, ubj, &
3732 & imins, imaxs, jmins, jmaxs, &
3733 & krhs, kstp, knew, &
3734 & ubar, vbar, zeta, &
3735 & tl_ubar, tl_vbar, tl_zeta)
3736!
3737! Compute integral mass flux across open boundaries and adjust
3738! for volume conservation.
3739!
3740 IF (any(tl_volcons(:,ng))) THEN
3741 CALL tl_obc_flux_tile (ng, tile, &
3742 & lbi, ubi, lbj, ubj, &
3743 & imins, imaxs, jmins, jmaxs, &
3744 & knew, &
3745#ifdef MASKING
3746 & umask, vmask, &
3747#endif
3748 & h, tl_h, om_v, on_u, &
3749 & ubar, vbar, zeta, &
3750 & tl_ubar, tl_vbar, tl_zeta)
3751 END IF
3752!
3753!-----------------------------------------------------------------------
3754! Apply momentum transport point sources (like river runoff), if any.
3755!
3756! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
3757! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
3758!-----------------------------------------------------------------------
3759!
3760 IF (luvsrc(ng)) THEN
3761 DO is=1,nsrc(ng)
3762 i=sources(ng)%Isrc(is)
3763 j=sources(ng)%Jsrc(is)
3764 IF (((istrr.le.i).and.(i.le.iendr)).and. &
3765 & ((jstrr.le.j).and.(j.le.jendr))) THEN
3766 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
3767 cff=1.0_r8/(on_u(i,j)* &
3768 & 0.5_r8*(zeta(i-1,j,knew)+h(i-1,j)+ &
3769 & zeta(i ,j,knew)+h(i ,j)))
3770 tl_cff=-cff*cff*on_u(i,j)* &
3771 & 0.5_r8*(tl_zeta(i-1,j,knew)+tl_h(i-1,j)+ &
3772 & tl_zeta(i ,j,knew)+tl_h(i ,j))
3773!^ ubar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3774!^
3775 tl_ubar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3776 & sources(ng)%Qbar(is)*tl_cff
3777 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
3778 cff=1.0_r8/(om_v(i,j)* &
3779 & 0.5_r8*(zeta(i,j-1,knew)+h(i,j-1)+ &
3780 & zeta(i,j ,knew)+h(i,j )))
3781 tl_cff=-cff*cff*om_v(i,j)* &
3782 & 0.5_r8*(tl_zeta(i,j-1,knew)+tl_h(i,j-1)+ &
3783 & tl_zeta(i,j ,knew)+tl_h(i,j ))
3784!^ vbar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3785!^
3786 tl_vbar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3787 & sources(ng)%Qbar(is)*tl_cff
3788 END IF
3789 END IF
3790 END DO
3791 END IF
3792!
3793!-----------------------------------------------------------------------
3794! Exchange boundary information.
3795!-----------------------------------------------------------------------
3796!
3797 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3798!^ CALL exchange_u2d_tile (ng, tile, &
3799!^ & LBi, UBi, LBj, UBj, &
3800!^ & ubar(:,:,knew))
3801!^
3802 CALL exchange_u2d_tile (ng, tile, &
3803 & lbi, ubi, lbj, ubj, &
3804 & tl_ubar(:,:,knew))
3805!^ CALL exchange_v2d_tile (ng, tile, &
3806!^ & LBi, UBi, LBj, UBj, &
3807!^ & vbar(:,:,knew))
3808!^
3809 CALL exchange_v2d_tile (ng, tile, &
3810 & lbi, ubi, lbj, ubj, &
3811 & tl_vbar(:,:,knew))
3812 END IF
3813
3814#ifdef DISTRIBUTE
3815!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3816!^ & LBi, UBi, LBj, UBj, &
3817!^ & NghostPoints, &
3818!^ & EWperiodic(ng), NSperiodic(ng), &
3819!^ & ubar(:,:,knew), &
3820!^ & vbar(:,:,knew))
3821!^
3822 CALL mp_exchange2d (ng, tile, itlm, 2, &
3823 & lbi, ubi, lbj, ubj, &
3824 & nghostpoints, &
3825 & ewperiodic(ng), nsperiodic(ng), &
3826 & tl_ubar(:,:,knew), &
3827 & tl_vbar(:,:,knew))
3828#endif
3829!
3830 RETURN

References mod_clima::clima, mod_scalars::compositegrid, mod_param::domain, mod_scalars::dt, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_r2d_tile(), exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_scalars::gamma2, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_scalars::inorth, mod_scalars::isouth, mod_ncparam::isubar, mod_ncparam::isvbar, mod_param::itlm, mod_scalars::iwest, mod_scalars::lnudgem2clm, mod_scalars::luvsrc, mod_scalars::lwsrc, mp_exchange_mod::mp_exchange2d(), mod_scalars::ndtfast, mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, mod_scalars::ntfirst, obc_volcons_mod::obc_flux_tile(), mod_scalars::predictor_2d_step, mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, mod_param::tl_lbc, tl_obc_volcons_mod::tl_obc_flux_tile(), tl_obc_volcons_mod::tl_set_duv_bc_tile(), tl_u2dbc_mod::tl_u2dbc_tile(), tl_v2dbc_mod::tl_v2dbc_tile(), mod_scalars::tl_volcons, tl_zetabc_mod::tl_zetabc_tile(), and mod_scalars::weight.

Here is the call graph for this function:

◆ tl_step2d_tile() [3/3]

subroutine tl_step2d_mod::tl_step2d_tile ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) ubk,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) krhs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) nnew,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) umask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vmask,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) pmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) umask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_wet,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) vmask_full,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) rmask_wet_avg,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) fomn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_h,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_u,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_v,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pm,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pn,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dndx,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) dmde,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rdrag,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rdrag2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pmon_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pnom_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) om_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) on_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc2_r,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_p,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) visc4_r,
real(r8), dimension(lbi:ubi,lbj:ubj,3), intent(in) tl_bed_thick,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rustr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvstr2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rulag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvlag2d,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_ubar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_vbar_stokes,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) eq_tide,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_eq_tide,
sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_sustr,
svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_svstr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) pair,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhoa,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_rhos,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_du_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_dv_avg2,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_zt_avg1,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rufrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(inout) tl_rvfrc,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rufrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rvfrc_bak,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) tl_du_flux,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(out) tl_dv_flux,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_ubar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_vbar,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(in) zeta,
real(r8), dimension(lbi:ubi,lbj:ubj,:), intent(inout) tl_zeta )
private

Definition at line 209 of file tl_step2d_FB.h.

294!***********************************************************************
295!
296! Imported variable declarations.
297!
298 integer, intent(in ) :: ng, tile
299 integer, intent(in ) :: LBi, UBi, LBj, UBj, UBk
300 integer, intent(in ) :: IminS, ImaxS, JminS, JmaxS
301 integer, intent(in ) :: krhs, kstp, knew
302#ifdef SOLVE3D
303 integer, intent(in ) :: nstp, nnew
304#endif
305!
306#ifdef ASSUMED_SHAPE
307# ifdef MASKING
308 real(r8), intent(in ) :: pmask(LBi:,LBj:)
309 real(r8), intent(in ) :: rmask(LBi:,LBj:)
310 real(r8), intent(in ) :: umask(LBi:,LBj:)
311 real(r8), intent(in ) :: vmask(LBi:,LBj:)
312# endif
313# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
314 real(r8), intent(in ) :: fomn(LBi:,LBj:)
315# endif
316 real(r8), intent(in ) :: h(LBi:,LBj:)
317 real(r8), intent(in ) :: om_u(LBi:,LBj:)
318 real(r8), intent(in ) :: om_v(LBi:,LBj:)
319 real(r8), intent(in ) :: on_u(LBi:,LBj:)
320 real(r8), intent(in ) :: on_v(LBi:,LBj:)
321 real(r8), intent(in ) :: pm(LBi:,LBj:)
322 real(r8), intent(in ) :: pn(LBi:,LBj:)
323# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
324 real(r8), intent(in ) :: dndx(LBi:,LBj:)
325 real(r8), intent(in ) :: dmde(LBi:,LBj:)
326# endif
327 real(r8), intent(in ) :: rdrag(LBi:,LBj:)
328# if defined UV_QDRAG && !defined SOLVE3D
329 real(r8), intent(in ) :: rdrag2(LBi:,LBj:)
330# endif
331# if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
332 real(r8), intent(in ) :: pmon_r(LBi:,LBj:)
333 real(r8), intent(in ) :: pnom_r(LBi:,LBj:)
334 real(r8), intent(in ) :: pmon_p(LBi:,LBj:)
335 real(r8), intent(in ) :: pnom_p(LBi:,LBj:)
336 real(r8), intent(in ) :: om_r(LBi:,LBj:)
337 real(r8), intent(in ) :: on_r(LBi:,LBj:)
338 real(r8), intent(in ) :: om_p(LBi:,LBj:)
339 real(r8), intent(in ) :: on_p(LBi:,LBj:)
340# ifdef UV_VIS2
341 real(r8), intent(in ) :: visc2_p(LBi:,LBj:)
342 real(r8), intent(in ) :: visc2_r(LBi:,LBj:)
343# endif
344# ifdef UV_VIS4
345 real(r8), intent(in ) :: visc4_p(LBi:,LBj:)
346 real(r8), intent(in ) :: visc4_r(LBi:,LBj:)
347# endif
348# endif
349# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
350 real(r8), intent(in ) :: tl_bed_thick(LBi:,LBj:,:)
351# endif
352# ifdef WEC_MELLOR
353 real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:)
354 real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:)
355# endif
356# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
357 real(r8), intent(in ) :: eq_tide(LBi:,LBj:)
358 real(r8), intent(in ) :: tl_eq_tide(LBi:,LBj:)
359# endif
360 real(r8), intent(in ) :: ubar(LBi:,LBj:,:)
361 real(r8), intent(in ) :: vbar(LBi:,LBj:,:)
362 real(r8), intent(in ) :: zeta(LBi:,LBj:,:)
363# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
364 real(r8), intent(inout) :: tl_h(LBi:,LBj:)
365# else
366 real(r8), intent(in ) :: tl_h(LBi:,LBj:)
367# endif
368# ifndef SOLVE3D
369 real(r8), intent(in ) :: tl_sustr(LBi:,LBj:)
370 real(r8), intent(in ) :: tl_svstr(LBi:,LBj:)
371# ifdef ATM_PRESS
372 real(r8), intent(in ) :: Pair(LBi:,LBj:)
373# endif
374# else
375# ifdef VAR_RHO_2D
376 real(r8), intent(in ) :: rhoA(LBi:,LBj:)
377 real(r8), intent(in ) :: rhoS(LBi:,LBj:)
378 real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:)
379 real(r8), intent(in ) :: tl_rhoS(LBi:,LBj:)
380# endif
381 real(r8), intent(in ) :: rufrc(LBi:,LBj:)
382 real(r8), intent(in ) :: rvfrc(LBi:,LBj:)
383
384 real(r8), intent(inout) :: tl_DU_avg1(LBi:,LBj:)
385 real(r8), intent(inout) :: tl_DU_avg2(LBi:,LBj:)
386 real(r8), intent(inout) :: tl_DV_avg1(LBi:,LBj:)
387 real(r8), intent(inout) :: tl_DV_avg2(LBi:,LBj:)
388 real(r8), intent(inout) :: tl_Zt_avg1(LBi:,LBj:)
389 real(r8), intent(inout) :: tl_rufrc(LBi:,LBj:)
390 real(r8), intent(inout) :: tl_rvfrc(LBi:,LBj:)
391 real(r8), intent(inout) :: tl_rufrc_bak(LBi:,LBj:,:)
392 real(r8), intent(inout) :: tl_rvfrc_bak(LBi:,LBj:,:)
393# endif
394# ifdef WEC_MELLOR
395 real(r8), intent(inout) :: tl_rustr2d(LBi:,LBj:)
396 real(r8), intent(inout) :: tl_rvstr2d(LBi:,LBj:)
397 real(r8), intent(inout) :: tl_rulag2d(LBi:,LBj:)
398 real(r8), intent(inout) :: tl_rvlag2d(LBi:,LBj:)
399 real(r8), intent(inout) :: tl_ubar_stokes(LBi:,LBj:)
400 real(r8), intent(inout) :: tl_vbar_stokes(LBi:,LBj:)
401# endif
402# ifdef WET_DRY_NOT_YET
403 real(r8), intent(inout) :: pmask_full(LBi:,LBj:)
404 real(r8), intent(inout) :: rmask_full(LBi:,LBj:)
405 real(r8), intent(inout) :: umask_full(LBi:,LBj:)
406 real(r8), intent(inout) :: vmask_full(LBi:,LBj:)
407
408 real(r8), intent(inout) :: pmask_wet(LBi:,LBj:)
409 real(r8), intent(inout) :: rmask_wet(LBi:,LBj:)
410 real(r8), intent(inout) :: umask_wet(LBi:,LBj:)
411 real(r8), intent(inout) :: vmask_wet(LBi:,LBj:)
412# ifdef SOLVE3D
413 real(r8), intent(inout) :: rmask_wet_avg(LBi:,LBj:)
414# endif
415# endif
416# ifdef DIAGNOSTICS_UV
417!! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:)
418!! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:)
419!! real(r8), intent(inout) :: DiaRUbar(LBi:,LBj:,:,:)
420!! real(r8), intent(inout) :: DiaRVbar(LBi:,LBj:,:,:)
421# ifdef SOLVE3D
422!! real(r8), intent(inout) :: DiaU2int(LBi:,LBj:,:)
423!! real(r8), intent(inout) :: DiaV2int(LBi:,LBj:,:)
424!! real(r8), intent(inout) :: DiaRUfrc(LBi:,LBj:,:,:)
425!! real(r8), intent(inout) :: DiaRVfrc(LBi:,LBj:,:,:)
426# endif
427# endif
428 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
429 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
430 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
431# if defined NESTING && !defined SOLVE3D
432 real(r8), intent(out ) :: tl_DU_flux(LBi:,LBj:)
433 real(r8), intent(out ) :: tl_DV_flux(LBi:,LBj:)
434# endif
435
436#else
437
438# ifdef MASKING
439 real(r8), intent(in ) :: pmask(LBi:UBi,LBj:UBj)
440 real(r8), intent(in ) :: rmask(LBi:UBi,LBj:UBj)
441 real(r8), intent(in ) :: umask(LBi:UBi,LBj:UBj)
442 real(r8), intent(in ) :: vmask(LBi:UBi,LBj:UBj)
443# endif
444# if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
445 real(r8), intent(in ) :: fomn(LBi:UBi,LBj:UBj)
446# endif
447 real(r8), intent(in ) :: h(LBi:UBi,LBj:UBj)
448 real(r8), intent(in ) :: om_u(LBi:UBi,LBj:UBj)
449 real(r8), intent(in ) :: om_v(LBi:UBi,LBj:UBj)
450 real(r8), intent(in ) :: on_u(LBi:UBi,LBj:UBj)
451 real(r8), intent(in ) :: on_v(LBi:UBi,LBj:UBj)
452 real(r8), intent(in ) :: pm(LBi:UBi,LBj:UBj)
453 real(r8), intent(in ) :: pn(LBi:UBi,LBj:UBj)
454# if defined CURVGRID && defined UV_ADV && !defined SOLVE3D
455 real(r8), intent(in ) :: dndx(LBi:UBi,LBj:UBj)
456 real(r8), intent(in ) :: dmde(LBi:UBi,LBj:UBj)
457# endif
458 real(r8), intent(in ) :: rdrag(LBi:UBi,LBj:UBj)
459# if defined UV_QDRAG && !defined SOLVE3D
460 real(r8), intent(in ) :: rdrag2(LBi:UBi,LBj:UBj)
461# endif
462# if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
463 real(r8), intent(in ) :: pmon_r(LBi:UBi,LBj:UBj)
464 real(r8), intent(in ) :: pnom_r(LBi:UBi,LBj:UBj)
465 real(r8), intent(in ) :: pmon_p(LBi:UBi,LBj:UBj)
466 real(r8), intent(in ) :: pnom_p(LBi:UBi,LBj:UBj)
467 real(r8), intent(in ) :: om_r(LBi:UBi,LBj:UBj)
468 real(r8), intent(in ) :: on_r(LBi:UBi,LBj:UBj)
469 real(r8), intent(in ) :: om_p(LBi:UBi,LBj:UBj)
470 real(r8), intent(in ) :: on_p(LBi:UBi,LBj:UBj)
471# ifdef UV_VIS2
472 real(r8), intent(in ) :: visc2_p(LBi:UBi,LBj:UBj)
473 real(r8), intent(in ) :: visc2_r(LBi:UBi,LBj:UBj)
474# endif
475# ifdef UV_VIS4
476 real(r8), intent(in ) :: visc4_p(LBi:UBi,LBj:UBj)
477 real(r8), intent(in ) :: visc4_r(LBi:UBi,LBj:UBj)
478# endif
479# endif
480# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
481 real(r8), intent(in ) :: tl_bed_thick(LBi:UBi,LBj:UBj,3)
482# endif
483# ifdef WEC_MELLOR
484 real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj)
485 real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj)
486# endif
487# if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
488 real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj)
489 real(r8), intent(in ) :: tl_eq_tide(LBi:UBi,LBj:UBj)
490# endif
491 real(r8), intent(in ) :: ubar(LBi:UBi,LBj:UBj,:)
492 real(r8), intent(in ) :: vbar(LBi:UBi,LBj:UBj,:)
493 real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:)
494# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
495 real(r8), intent(inout) :: tl_h(LBi:UBi,LBj:UBj)
496# else
497 real(r8), intent(in ) :: tl_h(LBi:UBi,LBj:UBj)
498# endif
499# ifndef SOLVE3D
500 real(r8), intent(in ) :: tl_sustr(LBi:UBi,LBj:UBj)
501 real(r8), intent(in ) :: tl_svstr(LBi:UBi,LBj:UBj)
502# ifdef ATM_PRESS
503 real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj)
504# endif
505# else
506# ifdef VAR_RHO_2D
507 real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj)
508 real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj)
509 real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj)
510 real(r8), intent(in ) :: tl_rhoS(LBi:UBi,LBj:UBj)
511# endif
512 real(r8), intent(in ) :: rufrc(LBi:UBi,LBj:UBj)
513 real(r8), intent(in ) :: rvfrc(LBi:UBi,LBj:UBj)
514
515 real(r8), intent(inout) :: tl_DU_avg1(LBi:UBi,LBj:UBj)
516 real(r8), intent(inout) :: tl_DU_avg2(LBi:UBi,LBj:UBj)
517 real(r8), intent(inout) :: tl_DV_avg1(LBi:UBi,LBj:UBj)
518 real(r8), intent(inout) :: tl_DV_avg2(LBi:UBi,LBj:UBj)
519 real(r8), intent(inout) :: tl_Zt_avg1(LBi:UBi,LBj:UBj)
520 real(r8), intent(inout) :: tl_rufrc(LBi:UBi,LBj:UBj)
521 real(r8), intent(inout) :: tl_rvfrc(LBi:UBi,LBj:UBj)
522 real(r8), intent(inout) :: tl_rufrc_bak(LBi:UBi,LBj:UBj,2)
523 real(r8), intent(inout) :: tl_rvfrc_bak(LBi:UBi,LBj:UBj,2)
524# endif
525# ifdef WEC_MELLOR
526 real(r8), intent(inout) :: tl_rustr2d(LBi:UBi,LBj:UBj)
527 real(r8), intent(inout) :: tl_rvstr2d(LBi:UBi,LBj:UBj)
528 real(r8), intent(inout) :: tl_rulag2d(LBi:UBi,LBj:UBj)
529 real(r8), intent(inout) :: tl_rvlag2d(LBi:UBi,LBj:UBj)
530 real(r8), intent(inout) :: tl_ubar_stokes(LBi:UBi,LBj:UBj)
531 real(r8), intent(inout) :: tl_vbar_stokes(LBi:UBi,LBj:UBj)
532# endif
533# ifdef WET_DRY_NOT_YET
534 real(r8), intent(inout) :: pmask_full(LBi:UBi,LBj:UBj)
535 real(r8), intent(inout) :: rmask_full(LBi:UBi,LBj:UBj)
536 real(r8), intent(inout) :: umask_full(LBi:UBi,LBj:UBj)
537 real(r8), intent(inout) :: vmask_full(LBi:UBi,LBj:UBj)
538
539 real(r8), intent(inout) :: pmask_wet(LBi:UBi,LBj:UBj)
540 real(r8), intent(inout) :: rmask_wet(LBi:UBi,LBj:UBj)
541 real(r8), intent(inout) :: umask_wet(LBi:UBi,LBj:UBj)
542 real(r8), intent(inout) :: vmask_wet(LBi:UBi,LBj:UBj)
543# ifdef SOLVE3D
544 real(r8), intent(inout) :: rmask_wet_avg(LBi:UBi,LBj:UBj)
545# endif
546# endif
547# ifdef DIAGNOSTICS_UV
548!! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d)
549!! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d)
550!! real(r8), intent(inout) :: DiaRUbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
551!! real(r8), intent(inout) :: DiaRVbar(LBi:UBi,LBj:UBj,2,NDM2d-1)
552# ifdef SOLVE3D
553!! real(r8), intent(inout) :: DiaU2int(LBi:UBi,LBj:UBj,NDM2d)
554!! real(r8), intent(inout) :: DiaV2int(LBi:UBi,LBj:UBj,NDM2d)
555!! real(r8), intent(inout) :: DiaRUfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
556!! real(r8), intent(inout) :: DiaRVfrc(LBi:UBi,LBj:UBj,3,NDM2d-1)
557# endif
558# endif
559 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
560 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
561 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
562# if defined NESTING && !defined SOLVE3D
563 real(r8), intent(out ) :: tl_DU_flux(LBi:UBi,LBj:UBj)
564 real(r8), intent(out ) :: tl_DV_flux(LBi:UBi,LBj:UBj)
565# endif
566#endif
567!
568! Local variable declarations.
569!
570 integer :: i, is, j
571 integer :: kbak, kold
572#ifdef DIAGNOSTICS_UV
573 integer :: idiag
574#endif
575!
576 real(r8) :: bkw0, bkw1, bkw2, bkw_new
577 real(r8) :: fwd0, fwd1, fwd2
578#ifdef SOLVE3D
579 real(r8) :: cfwd0, cfwd1, cfwd2
580#endif
581 real(r8) :: cff, cff1, cff2, cff3, cff4
582#ifdef WET_DRY_NOT_YET
583 real(r8) :: cff5, cff6, cff7
584#endif
585 real(r8) :: fac, fac1, fac2
586 real(r8) :: tl_cff, tl_cff1, tl_cff2, tl_cff3, tl_cff4
587#ifdef WET_DRY_NOT_YET
588 real(r8) :: tl_cff5, tl_cff6, tl_cff7
589#endif
590 real(r8) :: tl_fac, tl_fac1, tl_fac2
591#ifdef DEBUG
592 real(r8), parameter :: IniVal = 0.0_r8
593#endif
594!
595#if defined UV_C4ADVECTION && !defined SOLVE3D
596 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad
597#endif
598 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew
599 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dnew_rd
600 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs
601#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
602 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Drhs_p
603#endif
604 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp
605 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon
606 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom
607#ifdef WEC_MELLOR
608 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon
609 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom
610#endif
611#if defined STEP2D_CORIOLIS || !defined SOLVE3D
612 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx
613 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe
614#endif
615#if !defined SOLVE3D
616 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFe
617 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFx
618#endif
619#if defined UV_C4ADVECTION && !defined SOLVE3D
620 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad
621#endif
622 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2
623#if defined VAR_RHO_2D && defined SOLVE3D
624 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA
625#endif
626 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar
627 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar
628 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta
629 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: urhs
630 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: vrhs
631 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new
632 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zwrk
633#ifdef WET_DRY_NOT_YET
634 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: wetdry
635#endif
636#ifdef DIAGNOSTICS_UV
637!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Uwrk
638!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Vwrk
639!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaU2rhs
640!! real(r8), dimension(IminS:ImaxS,JminS:JmaxS,NDM2d-1) :: DiaV2rhs
641#endif
642!
643#if defined UV_C4ADVECTION && !defined SOLVE3D
644 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dgrad
645#endif
646 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dnew
647 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dnew_rd
648 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs
649#if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
650 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Drhs_p
651#endif
652 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_Dstp
653 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUon
654 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVom
655#ifdef WEC_MELLOR
656 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DUSon
657 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_DVSom
658#endif
659#if defined STEP2D_CORIOLIS || !defined SOLVE3D
660 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFx
661 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFe
662#endif
663#if !defined SOLVE3D
664 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_UFe
665 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_VFx
666#endif
667#if defined UV_C4ADVECTION && !defined SOLVE3D
668 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad
669#endif
670 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2
671#if defined VAR_RHO_2D && defined SOLVE3D
672 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA
673#endif
674 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta
675 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rubar
676 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rvbar
677 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_urhs
678 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_vrhs
679 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_zwrk
680!
681 real(r8), allocatable :: tl_zeta_new(:,:)
682
683#include "set_bounds.h"
684
685#ifdef DEBUG
686!
687!-----------------------------------------------------------------------
688! Initialize private arrays for debugging.
689!-----------------------------------------------------------------------
690!
691# if defined UV_C4ADVECTION && !defined SOLVE3D
692 dgrad=inival
693# endif
694 dnew=inival
695 dnew_rd=inival
696 drhs=inival
697# if (defined UV_VIS2 || defined UV_VIS4) && !defined SOLVE3D
698 drhs_p=inival
699# endif
700 dstp=inival
701 duon=inival
702 dvom=inival
703# if defined STEP2D_CORIOLIS || !defined SOLVE3D
704 ufx=inival
705 vfe=inival
706# endif
707# if !defined SOLVE3D
708 ufe=inival
709 vfx=inival
710# endif
711# if defined UV_C4ADVECTION && !defined SOLVE3D
712 grad=inival
713# endif
714 rzeta2=inival
715# if defined VAR_RHO_2D && defined SOLVE3D
716 rzetasa=inival
717# endif
718 rzeta=inival
719 rubar=inival
720 rvbar=inival
721 urhs=inival
722 vrhs=inival
723 zwrk=inival
724# ifdef WET_DRY_NOT_YET
725 wetdry=inival
726# endif
727# ifdef DIAGNOSTICS_UV
728 uwrk=inival
729 vwrk=inival
730 diau2rhs=inival
731 diav2rhs=inival
732# endif
733#endif
734!
735!-----------------------------------------------------------------------
736! Set coefficients for AB3-AM4 forward-backward algorithm.
737!-----------------------------------------------------------------------
738!
739! Because the Forward Euler step is used to update "zeta" during the
740! first barotropic step, the pressure-gradient term in the momentum
741! equation must be computed via the Backward step to keep it
742! numerically stable. However, this interferes with the computation
743! of forcing terms "rufrc" and "rvfrc" because the free surface in
744! pressure gradient computation in 3D is exactly at the time
745! corresponding to baroclinic step "nstp" (rather than ahead by one
746! barotropic step after it updated by a normal forward-backward step).
747! To resolve this conflict, the pressure gradient term is computed in
748! two stages during the first barotropic step. It uses zeta(:,:,kstp)
749! at first to ensure exact consistency with 3D model. Then, after
750! vertical integrals of 3D right-hand-side "rufrc" and "rvfrc" are
751! converted into forcing terms, add correction based on the difference
752! zeta_new(:,:)-zeta(:,:,kstp) to "rubar" and "rvbar" to make them
753! consistent with the Backward step for pressure gradient.
754! For pressure gradient terms, search for the label PGF_FB_CORRECTION
755! below.
756!
757 IF (first_2d_step) THEN ! Meaning of time indices
758 kbak=kstp !------------------------
759 kold=kstp ! m-2 m-1 m m+1
760 fwd0=1.0_r8 ! kold kbak kstp knew
761 fwd1=0.0_r8 ! fwd2 fwd1 fwd0
762 fwd2=0.0_r8 ! bkw2 bkw1 bkw0 bkw_new
763#ifdef SOLVE3D
764 bkw_new=0.0_r8
765 bkw0=1.0_r8
766#else
767 bkw_new=1.0_r8
768 bkw0=0.0_r8
769#endif
770 bkw1=0.0_r8
771 bkw2=0.0_r8
772 ELSE IF (first_2d_step+1) THEN
773 kbak=kstp-1
774 IF (kbak.lt.1) kbak=4
775 kold=kbak
776 fwd0=1.0_r8 ! Logically AB2-AM3 forward-
777 fwd1=0.0_r8 ! backward scheme with maximum
778 fwd2=0.0_r8 ! stability coefficients while
779 bkw_new=1.0833333333333_r8 ! maintaining third-order
780 bkw0=-0.1666666666666_r8 ! accuracy, alpha_max=1.73
781 bkw1= 0.0833333333333_r8
782 bkw2= 0.0_r8
783 ELSE
784 kbak=kstp-1
785 IF (kbak.lt.1) kbak=4
786 kold=kbak-1
787 IF (kold.lt.1) kold=4
788 fwd0=1.781105_r8
789 fwd1=-1.06221_r8
790 fwd2=0.281105_r8
791 bkw_new=0.614_r8
792 bkw0=0.285_r8
793 bkw1=0.0880_r8
794 bkw2=0.013_r8
795 END IF
796
797#ifdef DEBUG
798!
799 IF (master) THEN
800 WRITE (20,10) iic(ng), iif(ng), kold, kbak, kstp, knew
801 10 FORMAT (' iic = ',i5.5,' iif = ',i3.3, &
802 & ' kold = ',i1,' kbak = ',i1,' kstp = ',i1,' knew = ',i1)
803 END IF
804#endif
805!
806!-----------------------------------------------------------------------
807! Preliminary steps.
808!-----------------------------------------------------------------------
809!
810! Compute total depth of water column and vertically integrated fluxes
811! needed for computing horizontal divergence to advance free surface
812! and for advection terms for the barotropic momentum equations.
813! Set BASIC STATE for 'Drhs', 'urhs', and 'vrhs'.
814!
815#if defined DISTRIBUTE && !defined NESTING
816# define IR_RANGE IstrUm2-1,Iendp2
817# define JR_RANGE JstrVm2-1,Jendp2
818# define IU_RANGE IstrUm1-1,Iendp2
819# define JU_RANGE Jstrm1-1,Jendp2
820# define IV_RANGE Istrm1-1,Iendp2
821# define JV_RANGE JstrVm1-1,Jendp2
822#else
823# define IR_RANGE IstrUm2-1,Iendp2
824# define JR_RANGE JstrVm2-1,Jendp2
825# define IU_RANGE IstrUm2,Iendp2
826# define JU_RANGE JstrVm2-1,Jendp2
827# define IV_RANGE IstrUm2-1,Iendp2
828# define JV_RANGE JstrVm2,Jendp2
829#endif
830
831 DO j=jr_range
832 DO i=ir_range
833!^ Drhs(i,j)=h(i,j)+fwd0*zeta(i,j,kstp)+ &
834!^ & fwd1*zeta(i,j,kbak)+ &
835!^ & fwd2*zeta(i,j,kold)
836!^
837 drhs(i,j)=h(i,j)+zeta(i,j,kstp) ! using background value
838 tl_drhs(i,j)=tl_h(i,j)+fwd0*tl_zeta(i,j,kstp)+ &
839 & fwd1*tl_zeta(i,j,kbak)+ &
840 & fwd2*tl_zeta(i,j,kold)
841 END DO
842 END DO
843!
844 DO j=ju_range
845 DO i=iu_range
846 cff=0.5_r8*on_u(i,j)
847 cff1=cff*(drhs(i,j)+drhs(i-1,j))
848 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i-1,j))
849!^ urhs(i,j)=fwd0*ubar(i,j,kstp)+ &
850!^ & fwd1*ubar(i,j,kbak)+ &
851!^ & fwd2*ubar(i,j,kold)
852!^
853 urhs(i,j)=ubar(i,j,kstp) ! using background value
854 tl_urhs(i,j)=fwd0*tl_ubar(i,j,kstp)+ &
855 & fwd1*tl_ubar(i,j,kbak)+ &
856 & fwd2*tl_ubar(i,j,kold)
857 duon(i,j)=urhs(i,j)*cff1
858 tl_duon(i,j)=tl_urhs(i,j)*cff1+ &
859 & urhs(i,j)*tl_cff1
860 END DO
861 END DO
862!
863 DO j=jv_range
864 DO i=iv_range
865 cff=0.5_r8*om_v(i,j)
866 cff1=cff*(drhs(i,j)+drhs(i,j-1))
867 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i,j-1))
868!^ vrhs(i,j)=fwd0*vbar(i,j,kstp)+ &
869!^ & fwd1*vbar(i,j,kbak)+ &
870!^ & fwd2*vbar(i,j,kold)
871!^
872 vrhs(i,j)=vbar(i,j,kstp) ! using background value
873 tl_vrhs(i,j)=fwd0*tl_vbar(i,j,kstp)+ &
874 & fwd1*tl_vbar(i,j,kbak)+ &
875 & fwd2*tl_vbar(i,j,kold)
876 dvom(i,j)=vrhs(i,j)*cff1
877 tl_dvom(i,j)=tl_vrhs(i,j)*cff1+ &
878 & vrhs(i,j)*tl_cff1
879 END DO
880 END DO
881
882#undef IU_RANGE
883#undef IV_RANGE
884#undef JU_RANGE
885#undef JV_RANGE
886
887#if defined DISTRIBUTE && \
888 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
889!
890! In distributed-memory, the I- and J-ranges are different and a
891! special exchange is done here to avoid having three ghost points
892! for high-order numerical stencils. Notice that a private array is
893! passed below to the exchange routine. It also applies periodic
894! boundary conditions, if appropriate and no partitions in I- or
895! J-directions.
896!
897 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
898 CALL exchange_u2d_tile (ng, tile, &
899 & imins, imaxs, jmins, jmaxs, &
900 & duon)
901 CALL exchange_u2d_tile (ng, tile, &
902 & imins, imaxs, jmins, jmaxs, &
903 & tl_duon)
904 CALL exchange_v2d_tile (ng, tile, &
905 & imins, imaxs, jmins, jmaxs, &
906 & dvom)
907 CALL exchange_v2d_tile (ng, tile, &
908 & imins, imaxs, jmins, jmaxs, &
909 & tl_dvom)
910 END IF
911 CALL mp_exchange2d (ng, tile, itlm, 4, &
912 & imins, imaxs, jmins, jmaxs, &
913 & nghostpoints, &
914 & ewperiodic(ng), nsperiodic(ng), &
915 & duon, dvom, &
916 & tl_duon, tl_dvom)
917#endif
918!
919! Compute integral mass flux across open boundaries and adjust
920! for volume conservation. Compute BASIC STATE value.
921! HGA: Need to resolve 'krhs' index here.
922!
923 IF (any(volcons(:,ng))) THEN
924 CALL obc_flux_tile (ng, tile, &
925 & lbi, ubi, lbj, ubj, &
926 & imins, imaxs, jmins, jmaxs, &
927 & knew, &
928#ifdef MASKING
929 & umask, vmask, &
930#endif
931 & h, om_v, on_u, &
932 & ubar, vbar, zeta)
933!
934 CALL tl_obc_flux_tile (ng, tile, &
935 & lbi, ubi, lbj, ubj, &
936 & imins, imaxs, jmins, jmaxs, &
937 & knew, &
938# ifdef MASKING
939 & umask, vmask, &
940# endif
941 & h, tl_h, om_v, on_u, &
942 & ubar, vbar, zeta, &
943 & tl_ubar, tl_vbar, tl_zeta)
944!
945! Set vertically integrated mass fluxes DUon and DVom along the open
946! boundaries in such a way that the integral volume is conserved.
947!
948 CALL set_duv_bc_tile (ng, tile, &
949 & lbi, ubi, lbj, ubj, &
950 & imins, imaxs, jmins, jmaxs, &
951 & krhs, &
952#ifdef MASKING
953 & umask, vmask, &
954#endif
955 & om_v, on_u, &
956 & ubar, vbar, &
957 & drhs, duon, dvom)
958 CALL tl_set_duv_bc_tile (ng, tile, &
959 & lbi, ubi, lbj, ubj, &
960 & imins, imaxs, jmins, jmaxs, &
961 & krhs, &
962#ifdef MASKING
963 & umask, vmask, &
964#endif
965 & om_v, on_u, &
966 & ubar, vbar, &
967 & tl_ubar, tl_vbar, &
968 & drhs, duon, dvom, &
969 & tl_drhs, tl_duon, tl_dvom)
970 END IF
971!
972!-----------------------------------------------------------------------
973! Advance free-surface.
974!-----------------------------------------------------------------------
975!
976! Notice that the new local free-surface is allocated so it can be
977! passed as an argumment to "zetabc_local". An automatic array cannot
978! be used here because of weird memory problems.
979!
980 allocate ( tl_zeta_new(imins:imaxs,jmins:jmaxs) )
981 tl_zeta_new = 0.0_r8
982!
983! Get background zeta_new from BASIC state. Notice the I- and J-range
984! used to avoid calling nonlinear 'zetabc_local' routine.
985!
986 DO j=jr_range
987 DO i=ir_range
988 zeta_new(i,j)=zeta(i,j,knew)
989#ifdef MASKING
990 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
991# ifdef WET_DRY_NOT_YET
992!! zeta_new(i,j)=zeta_new(i,j)+ &
993!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
994# endif
995#endif
996 dnew(i,j)=h(i,j)+zeta_new(i,j)
997 dnew_rd(i,j)=dnew(i,j)
998 dstp(i,j)=h(i,j)+zeta(i,j,kstp)
999 END DO
1000 END DO
1001
1002#undef IR_RANGE
1003#undef JR_RANGE
1004!
1005! Compute "zeta_new" at new time step and interpolate it half-step
1006! backward, "zwrk" for the subsequent computation of the tangent
1007! linear barotropic pressure gradient. Here, we use the BASIC STATE
1008! values. Thus, the nonlinear correction to the pressure-gradient
1009! term from "kstp" to "knew" is not needed for Forward-Euler to
1010! Forward-Backward steps (PGF_FB_CORRECTION method).
1011!
1012 DO j=jstrv-1,jend
1013 DO i=istru-1,iend
1014 fac=dtfast(ng)*pm(i,j)*pn(i,j)
1015!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1016!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
1017!^ & DVom(i,j)-DVom(i,j+1))
1018!^
1019 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1020 & fac*(tl_duon(i,j)-tl_duon(i+1,j)+ &
1021 & tl_dvom(i,j)-tl_dvom(i,j+1))
1022#ifdef MASKING
1023!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1024!^
1025 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1026# ifdef WET_DRY_NOT_YET
1027!! zeta_new(i,j)=zeta_new(i,j)+ &
1028!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
1029# endif
1030#endif
1031 zwrk(i,j)=bkw_new*zeta_new(i,j)+ &
1032 & bkw0*zeta(i,j,kstp)+ &
1033 & bkw1*zeta(i,j,kbak)+ &
1034 & bkw2*zeta(i,j,kold)
1035 tl_zwrk(i,j)=bkw_new*tl_zeta_new(i,j)+ &
1036 & bkw0*tl_zeta(i,j,kstp)+ &
1037 & bkw1*tl_zeta(i,j,kbak)+ &
1038 & bkw2*tl_zeta(i,j,kold)
1039
1040#if defined VAR_RHO_2D && defined SOLVE3D
1041 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
1042 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
1043 & tl_rhos(i,j)*zwrk(i,j)
1044 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
1045 tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
1046 & rzeta(i,j)*tl_zwrk(i,j)
1047 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1048 tl_rzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1049 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))
1050#else
1051 rzeta(i,j)=zwrk(i,j)
1052 tl_rzeta(i,j)=tl_zwrk(i,j)
1053 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1054 tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)
1055#endif
1056 END DO
1057 END DO
1058!
1059! Apply mass point sources (volume vertical influx), if any.
1060!
1061! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
1062!
1063 IF (lwsrc(ng)) THEN
1064 DO is=1,nsrc(ng)
1065 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
1066 i=sources(ng)%Isrc(is)
1067 j=sources(ng)%Jsrc(is)
1068 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1069 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1070!^ zeta_new(i,j)=zeta_new(i,j)+ &
1071!^ & SOURCES(ng)%Qbar(is)* &
1072!^ & pm(i,j)*pn(i,j)*dtfast(ng)
1073!^
1074! tl_zeta_new(i,j)=tl_zeta_new(i,j)+0.0_r8
1075 END IF
1076 END IF
1077 END DO
1078 END IF
1079!
1080! Apply boundary conditions to newly computed free-surface "zeta_new".
1081! Notice that we are using the local routine, which passes the private
1082! "zeta_new" array as argument.
1083!
1084! Here, we use the local "zetabc" since the private array "zeta_new"
1085! is passed as an argument to allow computing the lateral boundary
1086! conditions on the range IstrU-1:Iend and JstrV-1:Jend, so parallel
1087! tile exchanges are avoided.
1088!
1089!^ CALL zetabc_local (ng, tile, &
1090!^ & LBi, UBi, LBj, UBj, &
1091!^ & IminS, ImaxS, JminS, JmaxS, &
1092!^ & kstp, &
1093!^ & zeta, &
1094!^ & zeta_new)
1095!^
1096 CALL tl_zetabc_local (ng, tile, &
1097 & lbi, ubi, lbj, ubj, &
1098 & imins, imaxs, jmins, jmaxs, &
1099 & kstp, &
1100 & zeta, tl_zeta, &
1101 & zeta_new, tl_zeta_new)
1102!
1103! Load new computed free-surface into global state array.
1104!
1105 DO j=jstrr,jendr
1106 DO i=istrr,iendr
1107!^ zeta(i,j,knew)=zeta_new(i,j)
1108!^
1109 tl_zeta(i,j,knew)=tl_zeta_new(i,j)
1110 END DO
1111 END DO
1112
1113#ifdef SOLVE3D
1114!
1115!-----------------------------------------------------------------------
1116! Compute fast-time-averaged fields over all barotropic time steps.
1117!-----------------------------------------------------------------------
1118!
1119! Reset/initialize arrays for averaged fields during the first
1120! barotropic time step. Then, accumulate it time average. Include
1121! physical boundary points, but not periodic ghost points or
1122! computation distributed-memory computational margins.
1123!
1124 cff1=weight(1,iif(ng),ng)
1125 cff2=weight(2,iif(ng),ng)
1126!
1127 IF (first_2d_step) THEN
1128 DO j=jstrr,jendr
1129 DO i=istrr,iendr
1130!^ Zt_avg1(i,j)=cff1*zeta(i,j,knew)
1131!^
1132 tl_zt_avg1(i,j)=cff1*tl_zeta(i,j,knew)
1133 IF (i.ge.istr) THEN
1134!^ DU_avg1(i,j)=0.0_r8
1135!^
1136 tl_du_avg1(i,j)=0.0_r8
1137!^ DU_avg2(i,j)=cff2*DUon(i,j)
1138!^
1139 tl_du_avg2(i,j)=cff2*tl_duon(i,j)
1140 END IF
1141 IF (j.ge.jstr) THEN
1142!^ DV_avg1(i,j)=0.0_r8
1143!^
1144 tl_dv_avg1(i,j)=0.0_r8
1145!^ DV_avg2(i,j)=cff2*DVom(i,j)
1146!^
1147 tl_dv_avg2(i,j)=cff2*tl_dvom(i,j)
1148 END IF
1149 END DO
1150 END DO
1151 ELSE
1152 DO j=jstrr,jendr
1153 DO i=istrr,iendr
1154!^ Zt_avg1(i,j)=Zt_avg1(i,j)+cff1*zeta(i,j,knew)
1155!^
1156 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+cff1*tl_zeta(i,j,knew)
1157 IF (i.ge.istr) THEN
1158!^ DU_avg2(i,j)=DU_avg2(i,j)+cff2*DUon(i,j)
1159!^
1160 tl_du_avg2(i,j)=tl_du_avg2(i,j)+cff2*tl_duon(i,j)
1161 END IF
1162 IF (j.ge.jstr) THEN
1163!^ DV_avg2(i,j)=DV_avg2(i,j)+cff2*DVom(i,j)
1164!^
1165 tl_dv_avg2(i,j)=tl_dv_avg2(i,j)+cff2*tl_dvom(i,j)
1166 END IF
1167 END DO
1168 END DO
1169 END IF
1170#endif
1171!
1172!=======================================================================
1173! Compute right-hand-side for the 2D momentum equations.
1174!=======================================================================
1175#ifdef SOLVE3D
1176!
1177! Notice that we are suppressing the computation of momentum advection,
1178! Coriolis, and lateral viscosity terms in 3D Applications because
1179! these terms are already included in the baroclinic-to-barotropic
1180! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely
1181! omitting them, but it is a choice between recomputing them at every
1182! barotropic step or keeping them "frozen" during the fast-time
1183! stepping.
1184# ifdef STEP2D_CORIOLIS
1185! However, in some coarse grid applications with larger baroclinic
1186! timestep (say, DT around 20 minutes or larger), adding the Coriolis
1187! term in the barotropic equations is useful since f*DT is no longer
1188! small.
1189# endif
1190#endif
1191!
1192!-----------------------------------------------------------------------
1193! Compute pressure-gradient terms.
1194!-----------------------------------------------------------------------
1195!
1196 cff1=0.5_r8*g
1197#if defined VAR_RHO_2D && defined SOLVE3D
1198 cff2=0.333333333333_r8
1199#endif
1200#if defined ATM_PRESS && !defined SOLVE3D
1201 cff3=0.5_r8*100.0_r8/rho0
1202#endif
1203 DO j=jstr,jend
1204 DO i=istr,iend
1205 IF (i.ge.istru) THEN
1206!^ rubar(i,j)=cff1*on_u(i,j)* &
1207!^ & ((h(i-1,j)+ &
1208!^ & h(i ,j))* &
1209!^ & (rzeta(i-1,j)- &
1210!^ & rzeta(i ,j))+ &
1211#if defined VAR_RHO_2D && defined SOLVE3D
1212!^ & (h(i-1,j)- &
1213!^ & h(i ,j))* &
1214!^ & (rzetaSA(i-1,j)+ &
1215!^ & rzetaSA(i ,j)+ &
1216!^ & cff2*(rhoA(i-1,j)- &
1217!^ & rhoA(i ,j))* &
1218!^ & (zwrk(i-1,j)- &
1219!^ & zwrk(i,j)))+ &
1220#endif
1221!^ & (rzeta2(i-1,j)- &
1222!^ & rzeta2(i ,j)))
1223!^
1224 tl_rubar(i,j)=cff1*on_u(i,j)* &
1225 & ((tl_h(i-1,j)+ &
1226 & tl_h(i ,j))* &
1227 & (rzeta(i-1,j)- &
1228 & rzeta(i ,j))+ &
1229 & (h(i-1,j)+ &
1230 & h(i ,j))* &
1231 & (tl_rzeta(i-1,j)- &
1232 & tl_rzeta(i ,j))+ &
1233#if defined VAR_RHO_2D && defined SOLVE3D
1234 & (tl_h(i-1,j)- &
1235 & tl_h(i ,j))* &
1236 & (rzetasa(i-1,j)+ &
1237 & rzetasa(i ,j)+ &
1238 & cff2*(rhoa(i-1,j)- &
1239 & rhoa(i ,j))* &
1240 & (zwrk(i-1,j)- &
1241 & zwrk(i ,j)))+ &
1242 & (h(i-1,j)- &
1243 & h(i ,j))* &
1244 & (tl_rzetasa(i-1,j)+ &
1245 & tl_rzetasa(i ,j)+ &
1246 & cff2*((tl_rhoa(i-1,j)- &
1247 & tl_rhoa(i ,j))* &
1248 & (zwrk(i-1,j)- &
1249 & zwrk(i ,j))+ &
1250 & (rhoa(i-1,j)- &
1251 & rhoa(i ,j))* &
1252 & (tl_zwrk(i-1,j)- &
1253 & tl_zwrk(i ,j))))+ &
1254#endif
1255 & (tl_rzeta2(i-1,j)- &
1256 & tl_rzeta2(i ,j)))
1257#if defined ATM_PRESS && !defined SOLVE3D
1258!^ rubar(i,j)=rubar(i,j)- &
1259!^ & cff3*on_u(i,j)* &
1260!^ & (h(i-1,j)+h(i,j)+ &
1261!^ & rzeta(i-1,j)+rzeta(i,j))* &
1262!^ & (Pair(i,j)-Pair(i-1,j))
1263!^
1264 tl_rubar(i,j)=tl_rubar(i,j)- &
1265 & cff3*on_u(i,j)* &
1266 & (tl_h(i-1,j)+tl_h(i,j)+ &
1267 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1268 & (pair(i,j)-pair(i-1,j))
1269#endif
1270#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1271!^ rubar(i,j)=rubar(i,j)- &
1272!^ & cff1*on_u(i,j)* &
1273!^ & (h(i-1,j)+h(i,j)+ &
1274!^ & rzeta(i-1,j)+rzeta(i,j))* &
1275!^ & (eq_tide(i,j)-eq_tide(i-1,j))
1276!^
1277 tl_rubar(i,j)=tl_rubar(i,j)- &
1278 & cff1*on_u(i,j)* &
1279 & ((tl_h(i-1,j)+tl_h(i,j)+ &
1280 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1281 & (eq_tide(i,j)-eq_tide(i-1,j))+ &
1282 & (h(i-1,j)+h(i,j)+ &
1283 & rzeta(i-1,j)+rzeta(i,j))* &
1284 & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))
1285#endif
1286#ifdef DIAGNOSTICS_UV
1287!! DiaU2rhs(i,j,M2pgrd)=rubar(i,j)
1288#endif
1289 END IF
1290!
1291 IF (j.ge.jstrv) THEN
1292!^ rvbar(i,j)=cff1*om_v(i,j)* &
1293!^ & ((h(i,j-1)+ &
1294!^ & h(i,j ))* &
1295!^ & (rzeta(i,j-1)- &
1296!^ & rzeta(i,j ))+ &
1297#if defined VAR_RHO_2D && defined SOLVE3D
1298!^ & (h(i,j-1)- &
1299!^ & h(i,j ))* &
1300!^ & (rzetaSA(i,j-1)+ &
1301!^ & rzetaSA(i,j )+ &
1302!^ & cff2*(rhoA(i,j-1)- &
1303!^ & rhoA(i,j ))* &
1304!^ & (zwrk(i,j-1)- &
1305!^ & zwrk(i,j )))+ &
1306#endif
1307!^ & (rzeta2(i,j-1)- &
1308!^ & rzeta2(i,j )))
1309!^
1310 tl_rvbar(i,j)=cff1*om_v(i,j)* &
1311 & ((tl_h(i,j-1)+ &
1312 & tl_h(i,j ))* &
1313 & (rzeta(i,j-1)- &
1314 & rzeta(i,j ))+ &
1315 & (h(i,j-1)+ &
1316 & h(i,j ))* &
1317 & (tl_rzeta(i,j-1)- &
1318 & tl_rzeta(i,j ))+ &
1319#if defined VAR_RHO_2D && defined SOLVE3D
1320 & (tl_h(i,j-1)- &
1321 & tl_h(i,j ))* &
1322 & (rzetasa(i,j-1)+ &
1323 & rzetasa(i,j )+ &
1324 & cff2*(rhoa(i,j-1)- &
1325 & rhoa(i,j ))* &
1326 & (zwrk(i,j-1)- &
1327 & zwrk(i,j )))+ &
1328 & (h(i,j-1)- &
1329 & h(i,j ))* &
1330 & (tl_rzetasa(i,j-1)+ &
1331 & tl_rzetasa(i,j )+ &
1332 & cff2*((tl_rhoa(i,j-1)- &
1333 & tl_rhoa(i,j ))* &
1334 & (zwrk(i,j-1)- &
1335 & zwrk(i,j ))+ &
1336 & (rhoa(i,j-1)- &
1337 & rhoa(i,j ))* &
1338 & (tl_zwrk(i,j-1)- &
1339 & tl_zwrk(i,j ))))+ &
1340#endif
1341 & (tl_rzeta2(i,j-1)- &
1342 & tl_rzeta2(i,j )))
1343#if defined ATM_PRESS && !defined SOLVE3D
1344!^ rvbar(i,j)=rvbar(i,j)- &
1345!^ & cff3*om_v(i,j)* &
1346!^ & (h(i,j-1)+h(i,j)+ &
1347!^ & rzeta(i,j-1)+rzeta(i,j))* &
1348!^ & (Pair(i,j)-Pair(i,j-1))
1349!^
1350 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1351 & cff3*om_v(i,j)* &
1352 & (tl_h(i,j-1)+tl_h(i,j)+ &
1353 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1354 & (pair(i,j)-pair(i,j-1))
1355#endif
1356#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1357!^ rvbar(i,j)=rvbar(i,j)- &
1358!^ & cff1*om_v(i,j)* &
1359!^ & (h(i,j-1)+h(i,j)+ &
1360!^ & rzeta(i,j-1)+rzeta(i,j))* &
1361!^ & (eq_tide(i,j)-eq_tide(i,j-1))
1362!^
1363 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1364 & cff1*om_v(i,j)* &
1365 & ((tl_h(i,j-1)+tl_h(i,j)+ &
1366 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1367 & (eq_tide(i,j)-eq_tide(i,j-1))+ &
1368 & (h(i,j-1)+h(i,j)+ &
1369 & rzeta(i,j-1)+rzeta(i,j))* &
1370 & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))
1371#endif
1372#ifdef DIAGNOSTICS_UV
1373!! DiaV2rhs(i,j,M2pgrd)=rvbar(i,j)
1374#endif
1375 END IF
1376 END DO
1377 END DO
1378
1379#if defined UV_ADV && !defined SOLVE3D
1380!
1381!-----------------------------------------------------------------------
1382! Add in horizontal advection of momentum.
1383!-----------------------------------------------------------------------
1384
1385# ifdef UV_C2ADVECTION
1386!
1387! Second-order, centered differences advection fluxes.
1388!
1389 DO j=jstr,jend
1390 DO i=istr-1,iend
1391 IF (i.ge.istru-1) THEN
1392!^ UFx(i,j)=0.25_r8* &
1393!^ & (DUon(i,j)+DUon(i+1,j))* &
1394!^ & (urhs(i ,j)+ &
1395# ifdef WEC_MELLOR
1396!^ & ubar_stokes(i ,j)+ &
1397!^ & ubar_stokes(i+1,j)+ &
1398# endif
1399!^ & urhs(i+1,j))
1400!^
1401 tl_ufx(i,j)=0.25_r8* &
1402 & ((tl_duon(i,j)+tl_duon(i+1,j))* &
1403 & (urhs(i ,j)+ &
1404# ifdef WEC_MELLOR
1405 & ubar_stokes(i ,j)+ &
1406 & ubar_stokes(i+1,j)+ &
1407# endif
1408 & urhs(i+1,j))+ &
1409 & (duon(i,j)+duon(i+1,j))* &
1410 & (tl_urhs(i ,j)+ &
1411# ifdef WEC_MELLOR
1412 & tl_ubar_stokes(i ,j)+ &
1413 & tl_ubar_stokes(i+1,j)+ &
1414# endif
1415 & tl_urhs(i+1,j)))
1416 END IF
1417!
1418!^ VFx(i+1,j)=0.25_r8* &
1419# ifdef MASKING
1420!^ pmask(i+1,j)* &
1421# endif
1422!^ & (DUon(i+1,j)+DUon(i+1,j-1))* &
1423!^ & (vrhs(i+1,j)+ &
1424# ifdef WEC_MELLOR
1425!^ & vbar_stokes(i ,j)+ &
1426!^ & vbar_stokes(i-1,j)+ &
1427# endif
1428!^ & vrhs(i ,j))
1429!^
1430 tl_vfx(i+1,j)=0.25_r8* &
1431# ifdef MASKING
1432 & pmask(i+1,j)* &
1433# endif
1434 & ((tl_duon(i+1,j)+tl_duon(i+1,j-1))* &
1435 & (vrhs(i+1,j)+ &
1436# ifdef WEC_MELLOR
1437 & vbar_stokes(i ,j)+ &
1438 & vbar_stokes(i-1,j)+ &
1439# endif
1440 & vrhs(i ,j))+ &
1441 & (duon(i+1,j)+duon(i+1,j-1))* &
1442 & (tl_vrhs(i+1,j)+ &
1443# ifdef WEC_MELLOR
1444 & tl_vbar_stokes(i ,j)+ &
1445 & tl_vbar_stokes(i-1,j)+ &
1446# endif
1447 & tl_vrhs(i ,j)))
1448 END DO
1449 END DO
1450!
1451 DO j=jstr-1,jend
1452 DO i=istr,iend
1453 IF (j.ge.jstrv-1) THEN
1454!^ VFe(i,j)=0.25_r8* &
1455!^ & (DVom(i,j)+DVom(i,j+1))* &
1456!^ & (vrhs(i,j )+ &
1457# ifdef WEC_MELLOR
1458!^ & vbar_stokes(i,j )+ &
1459!^ & vbar_stokes(i,j+1)+ &
1460# endif
1461!^ & vrhs(i,j+1))
1462!^
1463 tl_vfe(i,j)=0.25_r8* &
1464 & ((tl_dvom(i,j)+tl_dvom(i,j+1))* &
1465 & (vrhs(i,j )+ &
1466# ifdef WEC_MELLOR
1467 & vbar_stokes(i,j )+ &
1468 & vbar_stokes(i,j+1)+ &
1469# endif
1470 & vrhs(i,j+1))+ &
1471 & (dvom(i,j)+dvom(i,j+1))* &
1472 & (tl_vrhs(i,j )+ &
1473# ifdef WEC_MELLOR
1474 & tl_vbar_stokes(i,j )+ &
1475 & tl_vbar_stokes(i,j+1)+ &
1476# endif
1477 & tl_vrhs(i,j+1)))
1478 END IF
1479!
1480!^ UFe(i,j+1)=0.25_r8* &
1481# ifdef MASKING
1482!^ & pmask(i,j+1)* &
1483# endif
1484!^ & (DVom(i,j+1)+DVom(i-1,j+1))* &
1485!^ & (urhs(i,j+1)+ &
1486# ifdef WEC_MELLOR
1487!^ & ubar_stokes(i,j+1)+ &
1488!^ & ubar_stokes(i,j )+ &
1489# endif
1490!^ & urhs(i,j ))
1491!^
1492 tl_ufe(i,j+1)=0.25_r8* &
1493# ifdef MASKING
1494 & pmask(i,j+1)* &
1495# endif
1496 & ((tl_dvom(i,j+1)+tl_dvom(i-1,j+1))* &
1497 & (urhs(i,j+1)+ &
1498# ifdef WEC_MELLOR
1499 & ubar_stokes(i,j+1)+ &
1500 & ubar_stokes(i,j )+ &
1501# endif
1502 & urhs(i,j ))+ &
1503 & (dvom(i,j+1)+dvom(i-1,j+1))* &
1504 & (tl_urhs(i,j+1)+ &
1505# ifdef WEC_MELLOR
1506 & tl_ubar_stokes(i,j+1)+ &
1507 & tl_ubar_stokes(i,j )+ &
1508# endif
1509 & tl_urhs(i,j )))
1510 END DO
1511 END DO
1512
1513# elif defined UV_C4ADVECTION
1514!
1515! Fourth-order, centered differences u-momentum advection fluxes.
1516!
1517 DO j=jstr,jend
1518 DO i=istrum1,iendp1
1519 grad(i,j)=urhs(i-1,j)-2.0_r8*urhs(i,j)+ &
1520# ifdef WEC_MELLOR
1521 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
1522 & ubar_stokes(i+1,j)+ &
1523# endif
1524 & urhs(i+1,j)
1525 tl_grad(i,j)=tl_urhs(i-1,j)-2.0_r8*tl_urhs(i,j)+ &
1526# ifdef WEC_MELLOR
1527 & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
1528 & tl_ubar_stokes(i+1,j)+ &
1529# endif
1530 & tl_urhs(i+1,j)
1531 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
1532 tl_dgrad(i,j)=tl_duon(i-1,j)-2.0_r8*tl_duon(i,j)+ &
1533 & tl_duon(i+1,j)
1534 END DO
1535 END DO
1536 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1537 IF (domain(ng)%Western_Edge(tile)) THEN
1538 DO j=jstr,jend
1539 grad(istr,j)=grad(istr+1,j)
1540 tl_grad(istr,j)=tl_grad(istr+1,j)
1541 dgrad(istr,j)=dgrad(istr+1,j)
1542 tl_dgrad(istr,j)=tl_dgrad(istr+1,j)
1543 END DO
1544 END IF
1545 END IF
1546 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1547 IF (domain(ng)%Eastern_Edge(tile)) THEN
1548 DO j=jstr,jend
1549 grad(iend+1,j)=grad(iend,j)
1550 tl_grad(iend+1,j)=tl_grad(iend,j)
1551 dgrad(iend+1,j)=dgrad(iend,j)
1552 tl_dgrad(iend+1,j)=tl_dgrad(iend,j)
1553 END DO
1554 END IF
1555 END IF
1556! d/dx(Duu/n)
1557 cff=1.0_r8/6.0_r8
1558 DO j=jstr,jend
1559 DO i=istru-1,iend
1560!^ UFx(i,j)=0.25_r8*(urhs(i ,j)+ &
1561# ifdef WEC_MELLOR
1562!^ & ubar_stokes(i ,j)+ &
1563!^ & ubar_stokes(i+1,j)+ &
1564# endif
1565!^ & urhs(i+1,j)- &
1566!^ & cff*(grad (i,j)+grad (i+1,j)))* &
1567!^ & (DUon(i,j)+DUon(i+1,j)- &
1568!^ & cff*(Dgrad(i,j)+Dgrad(i+1,j)))
1569!^
1570 tl_ufx(i,j)=0.25_r8* &
1571 & ((urhs(i ,j)+ &
1572# ifdef WEC_MELLOR
1573 & ubar_stokes(i ,j)+ &
1574 & ubar_stokes(i+1,j)+ &
1575# endif
1576 & urhs(i+1,j)- &
1577 & cff*(grad(i,j)+grad(i+1,j)))* &
1578 & (tl_duon(i,j)+tl_duon(i+1,j)- &
1579 & cff*(tl_dgrad(i,j)+tl_dgrad(i+1,j)))+ &
1580 & (tl_urhs(i ,j)+ &
1581# ifdef WEC_MELLOR
1582 & tl_ubar_stokes(i ,j)+ &
1583 & tl_ubar_stokes(i+1,j)+ &
1584# endif
1585 & tl_urhs(i+1,j)- &
1586 & cff*(tl_grad(i,j)+tl_grad(i+1,j)))* &
1587 & (duon(i,j)+duon(i+1,j)- &
1588 & cff*(dgrad(i,j)+dgrad(i+1,j))))
1589 END DO
1590 END DO
1591!
1592 DO j=jstrm1,jendp1
1593 DO i=istru,iend
1594 grad(i,j)=urhs(i,j-1)-2.0_r8*urhs(i,j)+ &
1595# ifdef WEC_MELLOR
1596 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
1597 & ubar_stokes(i,j+1)+ &
1598# endif
1599 & urhs(i,j+1)
1600 tl_grad(i,j)=tl_urhs(i,j-1)-2.0_r8*tl_urhs(i,j)+ &
1601# ifdef WEC_MELLOR
1602 & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
1603 & tl_ubar_stokes(i,j+1)+ &
1604# endif
1605 & tl_urhs(i,j+1)
1606 END DO
1607 END DO
1608 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1609 IF (domain(ng)%Southern_Edge(tile)) THEN
1610 DO i=istru,iend
1611 grad(i,jstr-1)=grad(i,jstr)
1612 tl_grad(i,jstr-1)=tl_grad(i,jstr)
1613 END DO
1614 END IF
1615 END IF
1616 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1617 IF (domain(ng)%Northern_Edge(tile)) THEN
1618 DO i=istru,iend
1619 grad(i,jend+1)=grad(i,jend)
1620 tl_grad(i,jend+1)=tl_grad(i,jend)
1621 END DO
1622 END IF
1623 END IF
1624 DO j=jstr,jend+1
1625 DO i=istru-1,iend
1626 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
1627 tl_dgrad(i,j)=tl_dvom(i-1,j)-2.0_r8*tl_dvom(i,j)+ &
1628 & tl_dvom(i+1,j)
1629 END DO
1630 END DO
1631! d/dy(Duv/m)
1632 cff=1.0_r8/6.0_r8
1633 DO j=jstr,jend+1
1634 DO i=istru,iend
1635!^ UFe(i,j)=0.25_r8*(urhs(i,j )+ &
1636# ifdef WEC_MELLOR
1637!^ & ubar_stokes(i,j )+ &
1638!^ & ubar_stokes(i,j-1)+ &
1639# endif
1640!^ & urhs(i,j-1)- &
1641!^ & cff*(grad (i,j)+grad (i,j-1)))* &
1642!^ & (DVom(i,j)+DVom(i-1,j)- &
1643!^ & cff*(Dgrad(i,j)+Dgrad(i-1,j)))
1644!^
1645 tl_ufe(i,j)=0.25_r8* &
1646 & ((tl_urhs(i,j )+ &
1647# ifdef WEC_MELLOR
1648 & tl_ubar_stokes(i,j )+ &
1649 & tl_ubar_stokes(i,j-1)+ &
1650# endif
1651 & tl_urhs(i,j-1)- &
1652 & cff*(tl_grad(i,j)+tl_grad(i,j-1)))* &
1653 & (dvom(i,j)+dvom(i-1,j)- &
1654 & cff*(dgrad(i,j)+dgrad(i-1,j)))+ &
1655 & (urhs(i,j )+ &
1656# ifdef WEC_MELLOR
1657 & ubar_stokes(i,j )+ &
1658 & ubar_stokes(i,j-1)+ &
1659# endif
1660 & urhs(i,j-1)- &
1661 & cff*(grad(i,j)+grad(i,j-1)))* &
1662 & (tl_dvom(i,j)+tl_dvom(i-1,j)- &
1663 & cff*(tl_dgrad(i,j)+tl_dgrad(i-1,j))))
1664 END DO
1665 END DO
1666!
1667! Fourth-order, centered differences v-momentum advection fluxes.
1668!
1669 DO j=jstrv,jend
1670 DO i=istrm1,iendp1
1671 grad(i,j)=vrhs(i-1,j)-2.0_r8*vrhs(i,j)+ &
1672# ifdef WEC_MELLOR
1673 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
1674 & vbar_stokes(i+1,j)+ &
1675# endif
1676 & vrhs(i+1,j)
1677 tl_grad(i,j)=tl_vrhs(i-1,j)-2.0_r8*tl_vrhs(i,j)+ &
1678# ifdef WEC_MELLOR
1679 & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
1680 & tl_vbar_stokes(i+1,j)+ &
1681# endif
1682 & tl_vrhs(i+1,j)
1683 END DO
1684 END DO
1685 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1686 IF (domain(ng)%Western_Edge(tile)) THEN
1687 DO j=jstrv,jend
1688 grad(istr-1,j)=grad(istr,j)
1689 tl_grad(istr-1,j)=tl_grad(istr,j)
1690 END DO
1691 END IF
1692 END IF
1693 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1694 IF (domain(ng)%Eastern_Edge(tile)) THEN
1695 DO j=jstrv,jend
1696 grad(iend+1,j)=grad(iend,j)
1697 tl_grad(iend+1,j)=tl_grad(iend,j)
1698 END DO
1699 END IF
1700 END IF
1701 DO j=jstrv-1,jend
1702 DO i=istr,iend+1
1703 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
1704 tl_dgrad(i,j)=tl_duon(i,j-1)-2.0_r8*tl_duon(i,j)+ &
1705 & tl_duon(i,j+1)
1706 END DO
1707 END DO
1708! d/dx(Duv/n)
1709 cff=1.0_r8/6.0_r8
1710 DO j=jstrv,jend
1711 DO i=istr,iend+1
1712!^ VFx(i,j)=0.25_r8*(vrhs(i ,j)+ &
1713# ifdef WEC_MELLOR
1714!^ & vbar_stokes(i ,j)+ &
1715!^ & vbar_stokes(i-1,j)+ &
1716# endif
1717!^ & vrhs(i-1,j)- &
1718!^ & cff*(grad (i,j)+grad (i-1,j)))* &
1719!^ & (DUon(i,j)+DUon(i,j-1)- &
1720!^ & cff*(Dgrad(i,j)+Dgrad(i,j-1)))
1721!^
1722 tl_vfx(i,j)=0.25_r8* &
1723 & ((tl_vrhs(i ,j)+ &
1724# ifdef WEC_MELLOR
1725 & tl_vbar_stokes(i ,j)+ &
1726 & tl_vbar_stokes(i-1,j)+ &
1727# endif
1728 & tl_vrhs(i-1,j)- &
1729 & cff*(tl_grad(i,j)+tl_grad(i-1,j)))* &
1730 & (duon(i,j)+duon(i,j-1)- &
1731 & cff*(dgrad(i,j)+dgrad(i,j-1)))+ &
1732 & (vrhs(i ,j)+ &
1733# ifdef WEC_MELLOR
1734 & vbar_stokes(i ,j)+ &
1735 & vbar_stokes(i-1,j)+ &
1736# endif
1737 & vrhs(i-1,j)- &
1738 & cff*(grad(i,j)+grad(i-1,j)))* &
1739 & (tl_duon(i,j)+tl_duon(i,j-1)- &
1740 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j-1))))
1741 END DO
1742 END DO
1743!
1744 DO j=jstrvm1,jendp1
1745 DO i=istr,iend
1746 grad(i,j)=vrhs(i,j-1)-2.0_r8*vrhs(i,j)+ &
1747# ifdef WEC_MELLOR
1748 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
1749 & vbar_stokes(i,j+1)+ &
1750# endif
1751 & vrhs(i,j+1)
1752 tl_grad(i,j)=tl_vrhs(i,j-1)-2.0_r8*tl_vrhs(i,j)+ &
1753# ifdef WEC_MELLOR
1754 & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
1755 & tl_vbar_stokes(i,j+1)+ &
1756# endif
1757 & tl_vrhs(i,j+1)
1758 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
1759 tl_dgrad(i,j)=tl_dvom(i,j-1)-2.0_r8*tl_dvom(i,j)+ &
1760 & tl_dvom(i,j+1)
1761 END DO
1762 END DO
1763 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1764 IF (domain(ng)%Southern_Edge(tile)) THEN
1765 DO i=istr,iend
1766 grad(i,jstr)=grad(i,jstr+1)
1767 tl_grad(i,jstr)=tl_grad(i,jstr+1)
1768 dgrad(i,jstr)=dgrad(i,jstr+1)
1769 tl_dgrad(i,jstr)=tl_dgrad(i,jstr+1)
1770 END DO
1771 END IF
1772 END IF
1773 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1774 IF (domain(ng)%Northern_Edge(tile)) THEN
1775 DO i=istr,iend
1776 grad(i,jend+1)=grad(i,jend)
1777 tl_grad(i,jend+1)=tl_grad(i,jend)
1778 dgrad(i,jend+1)=dgrad(i,jend)
1779 tl_dgrad(i,jend+1)=tl_dgrad(i,jend)
1780 END DO
1781 END IF
1782 END IF
1783! d/dy(Dvv/m)
1784 cff=1.0_r8/6.0_r8
1785 DO j=jstrv-1,jend
1786 DO i=istr,iend
1787!^ VFe(i,j)=0.25_r8*(vrhs(i,j )+ &
1788# ifdef WEC_MELLOR
1789!^ & vbar_stokes(i,j )+ &
1790!^ & vbar_stokes(i,j+1)+ &
1791# endif
1792!^ & vrhs(i,j+1)- &
1793!^ & cff*(grad (i,j)+grad (i,j+1)))* &
1794!^ & (DVom(i,j)+DVom(i,j+1)- &
1795!^ & cff*(Dgrad(i,j)+Dgrad(i,j+1)))
1796!^
1797 tl_vfe(i,j)=0.25_r8* &
1798 & ((tl_vrhs(i,j )+ &
1799# ifdef WEC_MELLOR
1800 & tl_vbar_stokes(i,j )+ &
1801 & tl_vbar_stokes(i,j+1)+ &
1802# endif
1803 & tl_vrhs(i,j+1)- &
1804 & cff*(tl_grad(i,j)+tl_grad(i,j+1)))* &
1805 & (dvom(i,j)+dvom(i,j+1)- &
1806 & cff*(dgrad(i,j)+dgrad(i,j+1)))+ &
1807 & (vrhs(i,j )+ &
1808# ifdef WEC_MELLOR
1809 & vbar_stokes(i,j )+ &
1810 & vbar_stokes(i,j+1)+ &
1811# endif
1812 & vrhs(i,j+1)- &
1813 & cff*(grad(i,j)+grad(i,j+1)))* &
1814 & (tl_dvom(i,j)+tl_dvom(i,j+1)- &
1815 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j+1))))
1816 END DO
1817 END DO
1818# endif
1819!
1820! Add advection to RHS terms.
1821!
1822 DO j=jstr,jend
1823 DO i=istr,iend
1824 IF (i.ge.istru) THEN
1825!^ cff1=UFx(i,j)-UFx(i-1,j)
1826!^
1827 tl_cff1=tl_ufx(i,j)-tl_ufx(i-1,j)
1828!^ cff2=UFe(i,j+1)-UFe(i,j)
1829!^
1830 tl_cff2=tl_ufe(i,j+1)-tl_ufe(i,j)
1831!^ fac1=cff1+cff2
1832!^
1833 tl_fac1=tl_cff1+tl_cff2
1834!^ rubar(i,j)=rubar(i,j)-fac1
1835!^
1836 tl_rubar(i,j)=tl_rubar(i,j)-tl_fac1
1837# if defined DIAGNOSTICS_UV
1838!! DiaU2rhs(i,j,M2xadv)=-cff1
1839!! DiaU2rhs(i,j,M2yadv)=-cff2
1840!! DiaU2rhs(i,j,M2hadv)=-fac1
1841# endif
1842 END IF
1843!
1844 IF (j.ge.jstrv) THEN
1845!^ cff3=VFx(i+1,j)-VFx(i,j)
1846!^
1847 tl_cff3=tl_vfx(i+1,j)-tl_vfx(i,j)
1848!^ cff4=VFe(i,j)-VFe(i,j-1)
1849!^
1850 tl_cff4=tl_vfe(i,j)-tl_vfe(i,j-1)
1851!^ fac2=cff3+cff4
1852!^
1853 tl_fac2=tl_cff3+tl_cff4
1854!^ rvbar(i,j)=rvbar(i,j)-fac2
1855!^
1856 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
1857# if defined DIAGNOSTICS_UV
1858!! DiaV2rhs(i,j,M2xadv)=-cff3
1859!! DiaV2rhs(i,j,M2yadv)=-cff4
1860!! DiaV2rhs(i,j,M2hadv)=-fac2
1861# endif
1862 END IF
1863 END DO
1864 END DO
1865#endif
1866
1867#if (defined UV_COR && !defined SOLVE3D) || defined STEP2D_CORIOLIS
1868!
1869!-----------------------------------------------------------------------
1870! Add in Coriolis term.
1871!-----------------------------------------------------------------------
1872!
1873 DO j=jstrv-1,jend
1874 DO i=istru-1,iend
1875 cff=0.5_r8*drhs(i,j)*fomn(i,j)
1876 tl_cff=0.5_r8*tl_drhs(i,j)*fomn(i,j)
1877!^ UFx(i,j)=cff*(vrhs(i,j )+ &
1878# ifdef WEC_MELLOR
1879!^ & vbar_stokes(i,j )+ &
1880!^ & vbar_stokes(i,j+1)+ &
1881# endif
1882!^ & vrhs(i,j+1))
1883!^
1884 tl_ufx(i,j)=tl_cff*(vrhs(i,j )+ &
1885# ifdef WEC_MELLOR
1886 & vbar_stokes(i,j )+ &
1887 & vbar_stokes(i,j+1)+ &
1888# endif
1889 & vrhs(i,j+1))+ &
1890 & cff*(tl_vrhs(i,j )+ &
1891# ifdef WEC_MELLOR
1892 & tl_vbar_stokes(i,j )+ &
1893 & tl_vbar_stokes(i,j+1)+ &
1894# endif
1895 & tl_vrhs(i,j+1))
1896!
1897!^ VFe(i,j)=cff*(urhs(i ,j)+ &
1898# ifdef WEC_MELLOR
1899!^ & ubar_stokes(i ,j)+ &
1900!^ & ubar_stokes(i+1,j)+ &
1901# endif
1902!^ & urhs(i+1,j))
1903!^
1904 tl_vfe(i,j)=tl_cff*(urhs(i ,j)+ &
1905# ifdef WEC_MELLOR
1906 & ubar_stokes(i ,j)+ &
1907 & ubar_stokes(i+1,j)+ &
1908# endif
1909 & urhs(i+1,j))+ &
1910 & cff*(tl_urhs(i ,j)+ &
1911# ifdef WEC_MELLOR
1912 & tl_ubar_stokes(i ,j)+ &
1913 & tl_ubar_stokes(i+1,j)+ &
1914# endif
1915 & tl_urhs(i+1,j))
1916 END DO
1917 END DO
1918!
1919 DO j=jstr,jend
1920 DO i=istr,iend
1921 IF (i.ge.istru) THEN
1922!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
1923!^
1924 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
1925!^ rubar(i,j)=rubar(i,j)+fac1
1926!^
1927 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
1928# if defined DIAGNOSTICS_UV
1929!! DiaU2rhs(i,j,M2fcor)=fac1
1930# endif
1931 END IF
1932!
1933 IF (j.ge.jstrv) THEN
1934!^ fac2=0.5_r8*(VFe(i,j)+VFe(i,j-1))
1935!^
1936 tl_fac2=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
1937!^ rvbar(i,j)=rvbar(i,j)-fac2
1938!^
1939 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
1940# if defined DIAGNOSTICS_UV
1941!! DiaV2rhs(i,j,M2fcor)=-fac2
1942# endif
1943 END IF
1944 END DO
1945 END DO
1946#endif
1947
1948#if (defined CURVGRID && defined UV_ADV) && !defined SOLVE3D
1949!
1950!-----------------------------------------------------------------------
1951! Add in curvilinear transformation terms.
1952!-----------------------------------------------------------------------
1953!
1954 DO j=jstrv-1,jend
1955 DO i=istru-1,iend
1956 cff1=0.5_r8*(vrhs(i,j )+ &
1957# ifdef WEC_MELLOR
1958 & vbar_stokes(i,j )+ &
1959 & vbar_stokes(i,j+1)+ &
1960# endif
1961 & vrhs(i,j+1))
1962 tl_cff1=0.5_r8*(tl_vrhs(i,j )+ &
1963# ifdef WEC_MELLOR
1964 & tl_vbar_stokes(i,j )+ &
1965 & tl_vbar_stokes(i,j+1)+ &
1966# endif
1967 & tl_vrhs(i,j+1))
1968!
1969 cff2=0.5_r8*(urhs(i ,j)+
1970# ifdef WEC_MELLOR
1971 & ubar_stokes(i ,j)+ &
1972 & ubar_stokes(i+1,j)+ &
1973# endif
1974 & urhs(i+1,j))
1975 tl_cff2=0.5_r8*(tl_urhs(i ,j)+ &
1976# ifdef WEC_MELLOR
1977 & tl_ubar_stokes(i ,j)+ &
1978 & tl_ubar_stokes(i+1,j)+ &
1979# endif
1980 & tl_urhs(i+1,j))
1981!
1982 cff3=cff1*dndx(i,j)
1983 tl_cff3=tl_cff1*dndx(i,j)
1984 cff4=cff2*dmde(i,j)
1985 tl_cff4=tl_cff2*dmde(i,j)
1986 cff=drhs(i,j)*(cff3-cff4)
1987 tl_cff=tl_drhs(i,j)*(cff3-cff4)+ &
1988 & drhs(i,j)*(tl_cff3-tl_cff4)
1989!^ UFx(i,j)=cff*cff1
1990!^
1991 tl_ufx(i,j)=tl_cff*cff1+cff*tl_cff1
1992!^ VFe(i,j)=cff*cff2
1993!^
1994 tl_vfe(i,j)=tl_cff*cff2+cff*tl_cff2
1995# if defined DIAGNOSTICS_UV
1996!! cff=Drhs(i,j)*cff4
1997!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
1998!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
1999# endif
2000 END DO
2001 END DO
2002!
2003 DO j=jstr,jend
2004 DO i=istr,iend
2005 IF (i.ge.istru) THEN
2006!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
2007!^
2008 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
2009!^ rubar(i,j)=rubar(i,j)+fac1
2010!^
2011 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2012# if defined DIAGNOSTICS_UV
2013!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
2014!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
2015!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
2016!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
2017# endif
2018 END IF
2019!
2020 IF (j.ge.jstrv) THEN
2021!^ fac1=0.5_r8*(VFe(i,j)+VFe(i,j-1))
2022!^
2023 tl_fac1=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
2024!^ rvbar(i,j)=rvbar(i,j)-fac1
2025!^
2026 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac1
2027# if defined DIAGNOSTICS_UV
2028!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
2029!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
2030!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
2031!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
2032# endif
2033 END IF
2034 END DO
2035 END DO
2036#endif
2037
2038#if defined UV_VIS2 && !defined SOLVE3D
2039!
2040!-----------------------------------------------------------------------
2041! Add in horizontal harmonic viscosity.
2042!-----------------------------------------------------------------------
2043!
2044! Compute total depth at PSI-points.
2045!
2046 DO j=jstr,jend+1
2047 DO i=istr,iend+1
2048 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2049 & drhs(i,j-1)+drhs(i-1,j-1))
2050 tl_drhs_p(i,j)=0.25_r8*(tl_drhs(i,j )+tl_drhs(i-1,j )+ &
2051 & tl_drhs(i,j-1)+tl_drhs(i-1,j-1))
2052 END DO
2053 END DO
2054!
2055! Compute flux-components of the horizontal divergence of the stress
2056! tensor (m5/s2) in XI- and ETA-directions.
2057!
2058 DO j=jstrv-1,jend
2059 DO i=istru-1,iend
2060!^ cff=visc2_r(i,j)*Drhs(i,j)*0.5_r8* &
2061!^ & (pmon_r(i,j)* &
2062!^ & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,kstp)- &
2063!^ & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,kstp))- &
2064!^ & pnom_r(i,j)* &
2065!^ & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,kstp)- &
2066!^ & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,kstp)))
2067!^
2068 tl_cff=visc2_r(i,j)*0.5_r8* &
2069 & (tl_drhs(i,j)* &
2070 & (pmon_r(i,j)* &
2071 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,kstp)- &
2072 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,kstp))- &
2073 & pnom_r(i,j)* &
2074 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,kstp)- &
2075 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,kstp)))+ &
2076 & drhs(i,j)* &
2077 & (pmon_r(i,j)* &
2078 & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,kstp)- &
2079 & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,kstp))- &
2080 & pnom_r(i,j)* &
2081 & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,kstp)- &
2082 & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,kstp))))
2083!^ UFx(i,j)=on_r(i,j)*on_r(i,j)*cff
2084!^
2085 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2086!^ VFe(i,j)=om_r(i,j)*om_r(i,j)*cff
2087!^
2088 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2089 END DO
2090 END DO
2091!
2092 DO j=jstr,jend+1
2093 DO i=istr,iend+1
2094!^ cff=visc2_p(i,j)*Drhs_p(i,j)*0.5_r8* &
2095!^ & (pmon_p(i,j)* &
2096!^ & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,kstp)- &
2097!^ & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,kstp))+ &
2098!^ & pnom_p(i,j)* &
2099!^ & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,kstp)- &
2100!^ & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,kstp)))
2101!^
2102 tl_cff=visc2_p(i,j)*0.5_r8* &
2103 & (tl_drhs_p(i,j)* &
2104 & (pmon_p(i,j)* &
2105 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,kstp)- &
2106 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,kstp))+ &
2107 & pnom_p(i,j)* &
2108 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,kstp)- &
2109 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,kstp)))+ &
2110 & drhs_p(i,j)* &
2111 & (pmon_p(i,j)* &
2112 & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,kstp)- &
2113 & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,kstp))+ &
2114 & pnom_p(i,j)* &
2115 & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,kstp)- &
2116 & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,kstp))))
2117# ifdef MASKING
2118!^ cff=cff*pmask(i,j)
2119!^
2120 tl_cff=tl_cff*pmask(i,j)
2121# endif
2122# ifdef WET_DRY_NOT_YET
2123!^ cff=cff*pmask_wet(i,j)
2124!^
2125 tl_cff=tl_cff*pmask_wet(i,j)
2126# endif
2127!^ UFe(i,j)=om_p(i,j)*om_p(i,j)*cff
2128!^
2129 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2130!^ VFx(i,j)=on_p(i,j)*on_p(i,j)*cff
2131!^
2132 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2133 END DO
2134 END DO
2135!
2136! Add in harmonic viscosity.
2137!
2138 DO j=jstr,jend
2139 DO i=istr,iend
2140 IF (i.ge.istru) THEN
2141!^ cff1=0.5_r8*(pn(i-1,j)+pn(i,j))*(UFx(i,j )-UFx(i-1,j))
2142!^
2143 tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2144 & (tl_ufx(i,j )-tl_ufx(i-1,j))
2145!^ cff2=0.5_r8*(pm(i-1,j)+pm(i,j))*(UFe(i,j+1)-UFe(i ,j))
2146!^
2147 tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2148 & (tl_ufe(i,j+1)-tl_ufe(i ,j))
2149!^ fac1=cff1+cff2
2150!^
2151 tl_fac1=tl_cff1+tl_cff2
2152!^ rubar(i,j)=rubar(i,j)+fac1
2153!^
2154 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2155# if defined DIAGNOSTICS_UV
2156!! DiaU2rhs(i,j,M2hvis)=fac1
2157!! DiaU2rhs(i,j,M2xvis)=cff1
2158!! DiaU2rhs(i,j,M2yvis)=cff2
2159# endif
2160 END IF
2161!
2162 IF (j.ge.jstrv) THEN
2163!^ cff1=0.5_r8*(pn(i,j-1)+pn(i,j))*(VFx(i+1,j)-VFx(i,j ))
2164!^
2165 tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2166 & (tl_vfx(i+1,j)-tl_vfx(i,j ))
2167!^ cff2=0.5_r8*(pm(i,j-1)+pm(i,j))*(VFe(i ,j)-VFe(i,j-1))
2168!^
2169 tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2170 & (tl_vfe(i ,j)-tl_vfe(i,j-1))
2171!^ fac1=cff1-cff2
2172!^
2173 tl_fac1=tl_cff1-tl_cff2
2174!^ rvbar(i,j)=rvbar(i,j)+fac1
2175!^
2176 tl_rvbar(i,j)=tl_rvbar(i,j)+tl_fac1
2177# if defined DIAGNOSTICS_UV
2178!! DiaV2rhs(i,j,M2hvis)=fac1
2179!! DiaV2rhs(i,j,M2xvis)= cff1
2180!! DiaV2rhs(i,j,M2yvis)=-cff2
2181# endif
2182 END IF
2183 END DO
2184 END DO
2185#endif
2186
2187#ifdef SOLVE3D
2188!
2189!-----------------------------------------------------------------------
2190! Coupling between 2D and 3D equations.
2191!-----------------------------------------------------------------------
2192!
2193! Before the first barotropic time step, arrays "rufrc" and "rvfrc"
2194! contain vertical integrals of the 3D right-hand-side terms for the
2195! momentum equations (including surface and bottom stresses). During
2196! the first barotropic time step, convert them into forcing terms by
2197! subtracting the fast-time "rubar" and "rvbar" from them.
2198!
2199! In the predictor-coupled mode, the resultant forcing terms "rufrc"
2200! and "rvfrc" are extrapolated forward in time, so they become
2201! centered effectively at time n+1/2. This is done using optimized
2202! Adams-Bashforth weights. In the code below, rufrc_bak(:,:,nstp) is
2203! at (n-1)time step, while rufrc_bak(:,:,3-nstp) is at (n-2). After
2204! its use as input, the latter is overwritten by the value at time
2205! step "nstp" (mathematically "n") during the next step.
2206!
2207! From now on, the computed forcing terms "rufrc" and "rvfrc" will
2208! remain constant during the fast-time stepping and will be added
2209! to "rubar" and "rvbar" during all subsequent barotropic steps.
2210!
2211 coupled_step : IF (first_2d_step) THEN
2212!
2213! Predictor coupled barotropic mode: Set coefficients for AB3-like
2214! forward-in-time extrapolation of 3D to 2D forcing terms "rufrc" and
2215! "rvfrc".
2216!
2217 IF (iic(ng).eq.ntstart(ng)) THEN
2218 cfwd0=1.0_r8
2219 cfwd1=0.0_r8
2220 cfwd2=0.0_r8
2221 ELSE IF (iic(ng).eq.ntstart(ng)+1) THEN
2222 cfwd0=1.5_r8
2223 cfwd1=-0.5_r8
2224 cfwd2=0.0_r8
2225 ELSE
2226 cfwd2=0.281105_r8
2227 cfwd1=-0.5_r8-2.0_r8*cfwd2
2228 cfwd0=1.5_r8+cfwd2
2229 END IF
2230!
2231 DO j=jstr,jend
2232 DO i=istr,iend
2233!
2234! Compensate for (cancel) bottom drag terms: at input into step2d
2235! "rufrc" and "rvfrc" contain bottom drag terms computed by 3D mode.
2236! However, there are no 2D counterparts in "rubar" and "rvbar" because
2237! 2D bottom drag will be computed implicitly during the final stage of
2238! updating ubar(:,:,knew) and vbar(:,:,knew) below. Note that unlike
2239! the other terms, the bottom drag should not be extrapolated forward,
2240! if "rufrc" and "rvfrc" are, so this cancelation needs to be done
2241! right now rather than at the bottom of this loop.
2242!
2243 IF (i.ge.istru) THEN
2244!^ rufrc(i,j)=rufrc(i,j)+ &
2245!^ & 0.5_r8*(rdrag(i,j)+rdrag(i-1,j))* &
2246!^ & om_u(i,j)*on_u(i,j)*ubar(i,j,kstp)
2247!^
2248 tl_rufrc(i,j)=tl_rufrc(i,j)+ &
2249 & 0.5_r8*(rdrag(i,j)+rdrag(i-1,j))* &
2250 & om_u(i,j)*on_u(i,j)*tl_ubar(i,j,kstp)
2251 END IF
2252!
2253 IF (j.ge.jstrv) THEN
2254!^ rvfrc(i,j)=rvfrc(i,j)+ &
2255!^ & 0.5_r8*(rdrag(i,j)+rdrag(i,j-1))* &
2256!^ & om_v(i,j)*on_v(i,j)*vbar(i,j,kstp)
2257!^
2258 tl_rvfrc(i,j)=tl_rvfrc(i,j)+ &
2259 & 0.5_r8*(rdrag(i,j)+rdrag(i,j-1))* &
2260 & om_v(i,j)*on_v(i,j)*tl_vbar(i,j,kstp)
2261 END IF
2262!
2263! Barotropic mode running predictor stage: forward extrapolation.
2264!
2265 IF (i.ge.istru) THEN
2266!^ cff1=rufrc(i,j)-rubar(i,j)
2267!^
2268 tl_cff1=tl_rufrc(i,j)-tl_rubar(i,j)
2269!^ rufrc(i,j)=cfwd0*cff1+ &
2270!^ & cfwd1*rufrc_bak(i,j, nstp)+ &
2271!^ & cfwd2*rufrc_bak(i,j,3-nstp)
2272!^
2273 tl_rufrc(i,j)=cfwd0*tl_cff1+ &
2274 & cfwd1*tl_rufrc_bak(i,j, nstp)+ &
2275 & cfwd2*tl_rufrc_bak(i,j,3-nstp)
2276!^ rufrc_bak(i,j,3-nstp)=cff1
2277!^
2278 tl_rufrc_bak(i,j,3-nstp)=tl_cff1
2279 END IF
2280!
2281 IF (j.ge.jstrv) THEN
2282!^ cff2=rvfrc(i,j)-rvbar(i,j)
2283!^
2284 tl_cff2=tl_rvfrc(i,j)-tl_rvbar(i,j)
2285!^ rvfrc(i,j)=cfwd0*cff2+ &
2286!^ & cfwd1*rvfrc_bak(i,j, nstp)+ &
2287!^ & cfwd2*rvfrc_bak(i,j,3-nstp)
2288!^
2289 tl_rvfrc(i,j)=cfwd0*tl_cff2+ &
2290 & cfwd1*tl_rvfrc_bak(i,j, nstp)+ &
2291 & cfwd2*tl_rvfrc_bak(i,j,3-nstp)
2292!^ rvfrc_bak(i,j,3-nstp)=cff2
2293!^
2294 tl_rvfrc_bak(i,j,3-nstp)=tl_cff2
2295 END IF
2296 END DO
2297 END DO
2298!
2299! Add correction term to shift pressure-gradient terms from "kstp" to
2300! "knew". That is, it converts the first 2D step from Forward-Euler
2301! to Forward-Backward (this is PGF_FB_CORRECTION mentioned above).
2302!
2303 DO j=jstrv-1,jend
2304 DO i=istru-1,iend
2305!^ zwrk(i,j)=zeta_new(i,j)-zeta(i,j,kstp)
2306!^
2307 tl_zwrk(i,j)=tl_zeta_new(i,j)-tl_zeta(i,j,kstp)
2308# if defined VAR_RHO_2D && defined SOLVE3D
2309!^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j)
2310!^
2311 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
2312 & tl_rhos(i,j)*zwrk(i,j)
2313!^ rzeta2(i,j)=rzeta(i,j)*(zeta_new(i,j)+zeta(i,j,kstp))
2314!^
2315 tl_rzeta2(i,j)=tl_rzeta(i,j)* &
2316 & (zeta_new(i,j)+zeta(i,j,kstp))+ &
2317 & rzeta(i,j)* &
2318 & (tl_zeta_new(i,j)+tl_zeta(i,j,kstp))
2319!^ rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))
2320!^
2321 tl_rzetasa(i,j)=tl_zwrk(i,j)* &
2322 & (rhos(i,j)-rhoa(i,j))+ &
2323 & zwrk(i,j)* &
2324 & (tl_rhos(i,j)-tl_rhoa(i,j))
2325# else
2326!^ rzeta(i,j)=zwrk(i,j)
2327!^
2328 tl_rzeta(i,j)=tl_zwrk(i,j)
2329!^ rzeta2(i,j)=zwrk(i,j)*(zeta_new(i,j)+zeta(i,j,kstp))
2330!^
2331 tl_rzeta2(i,j)=tl_zwrk(i,j)* &
2332 & (zeta_new(i,j)+zeta(i,j,kstp))+ &
2333 & zwrk(i,j)* &
2334 & (tl_zeta_new(i,j)+tl_zeta(i,j,kstp))
2335# endif
2336 END DO
2337 END DO
2338!
2339 cff1=0.5*g
2340# if defined VAR_RHO_2D && defined SOLVE3D
2341 cff2=0.333333333333_r8
2342# endif
2343 DO j=jstr,jend
2344 DO i=istr,iend
2345 IF (i.ge.istru) THEN
2346!^ rubar(i,j)=rubar(i,j)+ &
2347!^ & cff1*on_u(i,j)* &
2348!^ & ((h(i-1,j)+ &
2349!^ & h(i ,j))* &
2350!^ & (rzeta(i-1,j)- &
2351!^ & rzeta(i ,j))+ &
2352# if defined VAR_RHO_2D && defined SOLVE3D
2353!^ & (h(i-1,j)- &
2354!^ & h(i ,j))* &
2355!^ & (rzetaSA(i-1,j)+ &
2356!^ & rzetaSA(i ,j)+ &
2357!^ & cff2*(rhoA(i-1,j)- &
2358!^ & rhoA(i ,j))* &
2359!^ & (zwrk(i-1,j)- &
2360!^ & zwrk(i ,j)))+ &
2361# endif
2362!^ & (rzeta2(i-1,j)- &
2363!^ & rzeta2(i ,j)))
2364!^
2365 tl_rubar(i,j)=tl_rubar(i,j)+ &
2366 & cff1*on_u(i,j)* &
2367 & ((tl_h(i-1,j)+ &
2368 & tl_h(i ,j))* &
2369 & (rzeta(i-1,j)- &
2370 & rzeta(i ,j))+ &
2371 & (h(i-1,j)+ &
2372 & h(i ,j))* &
2373 & (tl_rzeta(i-1,j)- &
2374 & tl_rzeta(i ,j))+ &
2375# if defined VAR_RHO_2D && defined SOLVE3D
2376 & (tl_h(i-1,j)- &
2377 & tl_h(i ,j))* &
2378 & (rzetasa(i-1,j)+ &
2379 & rzetasa(i ,j)+ &
2380 & cff2*(rhoa(i-1,j)- &
2381 & rhoa(i ,j))* &
2382 & (zwrk(i-1,j)- &
2383 & zwrk(i ,j)))+ &
2384 & (h(i-1,j)- &
2385 & h(i ,j))* &
2386 & (tl_rzetasa(i-1,j)+ &
2387 & tl_rzetasa(i ,j)+ &
2388 & cff2*((tl_rhoa(i-1,j)- &
2389 & tl_rhoa(i ,j))* &
2390 & (zwrk(i-1,j)- &
2391 & zwrk(i ,j))+ &
2392 & (rhoa(i-1,j)- &
2393 & rhoa(i ,j))* &
2394 & (tl_zwrk(i-1,j)- &
2395 & tl_zwrk(i ,j))))+ &
2396# endif
2397 & (tl_rzeta2(i-1,j)- &
2398 & tl_rzeta2(i ,j)))
2399# ifdef DIAGNOSTICS_UV
2400!! DiaU2rhs(i,j,M2pgrd)=DiaU2rhs(i,j,M2pgrd)+ &
2401!! & rubar(i,j)
2402# endif
2403 END IF
2404!
2405 IF (j.ge.jstrv) THEN
2406!^ rvbar(i,j)=rvbar(i,j)+ &
2407!^ & cff1*om_v(i,j)* &
2408!^ & ((h(i,j-1)+ &
2409!^ & h(i,j ))* &
2410!^ & (rzeta(i,j-1)- &
2411!^ & rzeta(i,j ))+ &
2412# if defined VAR_RHO_2D && defined SOLVE3D
2413!^ & (h(i,j-1)- &
2414!^ & h(i,j ))* &
2415!^ & (rzetaSA(i,j-1)+ &
2416!^ & rzetaSA(i,j )+ &
2417!^ & cff2*(rhoA(i,j-1)- &
2418!^ & rhoA(i,j ))* &
2419!^ & (zwrk(i,j-1)- &
2420!^ & zwrk(i,j )))+ &
2421# endif
2422!^ & (rzeta2(i,j-1)- &
2423!^ & rzeta2(i,j )))
2424!^
2425 tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2426 & cff1*om_v(i,j)* &
2427 & ((tl_h(i,j-1)+ &
2428 & tl_h(i,j ))* &
2429 & (rzeta(i,j-1)- &
2430 & rzeta(i,j ))+ &
2431 & (h(i,j-1)+ &
2432 & h(i,j ))* &
2433 & (tl_rzeta(i,j-1)- &
2434 & tl_rzeta(i,j ))+ &
2435# if defined VAR_RHO_2D && defined SOLVE3D
2436 & (tl_h(i,j-1)- &
2437 & tl_h(i,j ))* &
2438 & (rzetasa(i,j-1)+ &
2439 & rzetasa(i,j )+ &
2440 & cff2*(rhoa(i,j-1)- &
2441 & rhoa(i,j ))* &
2442 & (zwrk(i,j-1)- &
2443 & zwrk(i,j )))+ &
2444 & (h(i,j-1)- &
2445 & h(i,j ))* &
2446 & (tl_rzetasa(i,j-1)+ &
2447 & tl_rzetasa(i,j )+ &
2448 & cff2*((tl_rhoa(i,j-1)- &
2449 & tl_rhoa(i,j ))* &
2450 & (zwrk(i,j-1)- &
2451 & zwrk(i,j ))+ &
2452 & (rhoa(i,j-1)- &
2453 & rhoa(i,j ))* &
2454 & (tl_zwrk(i,j-1)- &
2455 & tl_zwrk(i,j ))))+ &
2456# endif
2457 & (tl_rzeta2(i,j-1)- &
2458 & tl_rzeta2(i,j )))
2459# ifdef DIAGNOSTICS_UV
2460!! DiaV2rhs(i,j,M2pgrd)=DiaV2rhs(i,j,M2pgrd)+ &
2461!! & rvbar(i,j)
2462# endif
2463 END IF
2464 END DO
2465 END DO
2466 END IF coupled_step
2467#endif
2468!
2469!-----------------------------------------------------------------------
2470! Time step 2D momentum equations.
2471!-----------------------------------------------------------------------
2472!
2473! Advance 2D momentum components while simultaneously adding them to
2474! accumulate fast-time averages to compute barotropic fluxes. Doing so
2475! straight away yields a more computationally dense code. However, the
2476! fast-time averaged fluxes (DU_avg1 and DV_avg1) are needed both at
2477! the interior and physical boundary points. Thus, we need separate
2478! loops along the domain boundaries after setting "ubar" and "vbar"
2479! lateral boundary conditions. Also, note that bottom drag is treated
2480! implicitly:
2481!
2482! Dnew*ubar(:,:,m+1) = Dold*ubar(:,:,m) +
2483! dtfast(ng)*rhs2D(:,:) -
2484! dtfast(ng)*rdrag(:,:)*ubar(:,:,m+1)
2485! hence
2486!
2487! ubar(:,:,m+1)=[Dold * ubar(..,m) + dtfast(ng) * rhs2D(:,:)] /
2488! [Dnew + dtfast(ng) * rdrag(:,:)]
2489!
2490! DU_avg1 = DU_avg1 +
2491! weight(m+1) * Dnew * ubar(:,:,m+1) * on_u(:,:)
2492!
2493! where it should be noted that Dnew .ne. Dnew + dtfast * rdrag
2494!
2495 DO j=jstrv-1,jend
2496 DO i=istru-1,iend
2497!^ Dnew(i,j)=h(i,j)+zeta_new(i,j)
2498!^
2499 tl_dnew(i,j)=tl_h(i,j)+tl_zeta_new(i,j)
2500!^ Dnew_rd(i,j)=Dnew(i,j)+dtfast(ng)*rdrag(i,j)
2501!^
2502 tl_dnew_rd(i,j)=tl_dnew(i,j)
2503!^ Dstp(i,j)=h(i,j)+zeta(i,j,kstp)
2504!^
2505 tl_dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kstp)
2506 END DO
2507 END DO
2508
2509#if defined UV_QDRAG && !defined SOLVE3D
2510!
2511! Add quadratic drag term associated in shallow-water applications.
2512!
2513! Here, the SQRT(3) is due to a linear interpolation with second order
2514! accuaracy that ensures positive and negative values of the velocity
2515! components:
2516!
2517! u^2(i+1/2) = (1/3)*[u(i)*u(i) + u(i)*u(i+1) + u(i+1)*u(i+1)]
2518!
2519! If u(i)=1 and u(i+1)=-1, then u^2(i+1/2)=1/3 as it should be.
2520!
2521 cff=dtfast(ng)/sqrt(3.0_r8)
2522 DO j=jstrv-1,jend
2523 DO i=istru-1,iend
2524 cff1=ubar(i ,j,kstp)**2+ &
2525 & ubar(i+1,j,kstp)**2+ &
2526 & ubar(i ,j,kstp)*ubar(i+1,j,kstp)+ &
2527 & vbar(i,j ,kstp)**2+ &
2528 & vbar(i,j+1,kstp)**2+ &
2529 & vbar(i,j ,kstp)*vbar(i,j+1,kstp)
2530 tl_cff1=2.0_r8*ubar(i ,j,kstp)*tl_ubar(i ,j,kstp)+ &
2531 & 2.0_r8*ubar(i+1,j,kstp)*tl_ubar(i+1,j,kstp)+ &
2532 & tl_ubar(i ,j,kstp)*ubar(i+1,j,kstp)+ &
2533 & tl_ubar(i+1,j,kstp)*ubar(i ,j,kstp)+ &
2534 & 2.0_r8*vbar(i,j ,kstp)*tl_vbar(i,j ,kstp)+ &
2535 & 2.0_r8*vbar(i,j+1,kstp)*tl_ vbar(i,j+1,kstp)+ &
2536 & tl_vbar(i,j ,kstp)*vbar(i,j+1,kstp)+ &
2537 & tl_vbar(i,j+1,kstp)*vbar(i,j ,kstp)
2538 cff2=sqrt(cff1)
2539 tl_cff2=0.5_r8*tl_cff1/cff2
2540!^ Dnew_rd(i,j)=Dnew_rd(i,j)+ &
2541!^ & cff*rdrag2(i,j)*cff2
2542!^
2543 tl_dnew_rd(i,j)=tl_dnew_rd(i,j)+ &
2544 & cff*rdrag2(i,j)*tl_cff2
2545 END DO
2546 END DO
2547#endif
2548!
2549! Step 2D momentum equations.
2550!
2551 cff=0.5_r8*dtfast(ng)
2552#ifdef SOLVE3D
2553 cff1=0.5_r8*weight(1,iif(ng),ng)
2554#else
2555 cff2=2.0_r8*dtfast(ng)
2556#endif
2557 DO j=jstr,jend
2558 DO i=istru,iend
2559 cff3=cff*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
2560 fac1=1.0_r8/(dnew_rd(i,j)+dnew_rd(i-1,j))
2561 tl_fac1=-fac1*fac1*(tl_dnew_rd(i,j)+tl_dnew_rd(i-1,j))
2562!^ ubar(i,j,knew)=fac1* &
2563!^ & ((Dstp(i,j)+Dstp(i-1,j))*ubar(i,j,kstp)+ &
2564#ifdef SOLVE3D
2565!^ & cff3*(rubar(i,j)+rufrc(i,j)))
2566#else
2567!^ & cff3*rubar(i,j)+cff2*sustr(i,j))
2568#endif
2569!^
2570 tl_ubar(i,j,knew)=tl_fac1* &
2571 & ((dstp(i,j)+dstp(i-1,j))*ubar(i,j,kstp)+ &
2572#ifdef SOLVE3D
2573 & cff3*(rubar(i,j)+rufrc(i,j)))+ &
2574#else
2575 & cff3*rubar(i,j)+cff2*sustr(i,j))+ &
2576#endif
2577 & fac1* &
2578 & ((dstp(i,j)+dstp(i-1,j))* &
2579 & tl_ubar(i,j,kstp)+ &
2580 & (tl_dstp(i,j)+tl_dstp(i-1,j))* &
2581 & ubar(i,j,kstp)+ &
2582#ifdef SOLVE3D
2583 & cff3*(tl_rubar(i,j)+tl_rufrc(i,j)))
2584#else
2585 & cff3*tl_rubar(i,j)+cff2*tl_sustr(i,j))
2586#endif
2587#ifdef MASKING
2588!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
2589!^
2590 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
2591#endif
2592#ifdef WET_DRY_NOT_YET
2593!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
2594!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
2595!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2596!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
2597!^
2598!^ HGA: TLM code needed here.
2599!^
2600#endif
2601#ifdef SOLVE3D
2602!^ DU_avg1(i,j)=DU_avg1(i,j)+ &
2603!^ & cff1*on_u(i,j)* &
2604!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2605!^
2606 tl_du_avg1(i,j)=tl_du_avg1(i,j)+ &
2607 & cff1*on_u(i,j)* &
2608 & ((dnew(i,j)+dnew(i-1,j))* &
2609 & tl_ubar(i,j,knew)+ &
2610 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2611 & ubar(i,j,knew))
2612#endif
2613#if defined NESTING && !defined SOLVE3D
2614!^ DU_flux(i,j)=0.5_r8*on_u(i,j)* &
2615!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2616!^
2617 tl_du_flux(i,j)=0.5_r8*on_u(i,j)* &
2618 & ((dnew(i,j)+dnew(i-1,j))* &
2619 & tl_ubar(i,j,knew)+ &
2620 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2621 & ubar(i,j,knew))
2622#endif
2623 END DO
2624 END DO
2625!
2626 DO j=jstrv,jend
2627 DO i=istr,iend
2628 cff3=cff*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
2629 fac2=1.0_r8/(dnew_rd(i,j)+dnew_rd(i,j-1))
2630 tl_fac2=-fac2*fac2*(tl_dnew_rd(i,j)+tl_dnew_rd(i,j-1))
2631!^ vbar(i,j,knew)=fac2* &
2632!^ & ((Dstp(i,j)+Dstp(i,j-1))*vbar(i,j,kstp)+ &
2633#ifdef SOLVE3D
2634!^ & cff3*(rvbar(i,j)+rvfrc(i,j)))
2635#else
2636!^ & cff3*rvbar(i,j)+cff2*svstr(i,j))
2637#endif
2638!^
2639 tl_vbar(i,j,knew)=tl_fac2* &
2640 & ((dstp(i,j)+dstp(i,j-1))*vbar(i,j,kstp)+ &
2641#ifdef SOLVE3D
2642 & cff3*(rvbar(i,j)+rvfrc(i,j)))+ &
2643#else
2644 & cff3*rvbar(i,j)+cff2*svstr(i,j))+ &
2645#endif
2646 & fac2* &
2647 & ((dstp(i,j)+dstp(i,j-1))* &
2648 & tl_vbar(i,j,kstp)+ &
2649 & (tl_dstp(i,j)+tl_dstp(i,j-1))* &
2650 & vbar(i,j,kstp)+ &
2651#ifdef SOLVE3D
2652 & cff3*(tl_rvbar(i,j)+tl_rvfrc(i,j)))
2653#else
2654 & cff3*tl_rvbar(i,j)+cff2*tl_svstr(i,j))
2655#endif
2656#ifdef MASKING
2657!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
2658!^
2659 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
2660#endif
2661#ifdef WET_DRY_NOT_YET
2662!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
2663!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
2664!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2665!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
2666!^
2667!^ HGA: TLM code needed here.
2668!^
2669#endif
2670#ifdef SOLVE3D
2671!^ DV_avg1(i,j)=DV_avg1(i,j)+ &
2672!^ & cff1*om_v(i,j)* &
2673!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
2674!^
2675 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+ &
2676 & cff1*om_v(i,j)* &
2677 & ((dnew(i,j)+dnew(i,j-1))* &
2678 & tl_vbar(i,j,knew)+ &
2679 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
2680 & vbar(i,j,knew))
2681#endif
2682#if defined NESTING && !defined SOLVE3D
2683!^ DV_flux(i,j)=0.5_r8*om_v(i,j)* &
2684!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
2685!^
2686 tl_dv_flux(i,j)=0.5_r8*om_v(i,j)* &
2687 & ((dnew(i,j)+dnew(i,j-1))* &
2688 & tl_vbar(i,j,knew)+ &
2689 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
2690 & vbar(i,j,knew))
2691#endif
2692 END DO
2693 END DO
2694!
2695! Apply lateral boundary conditions.
2696!
2697!^ CALL u2dbc_tile (ng, tile, &
2698!^ & LBi, UBi, LBj, UBj, &
2699!^ & IminS, ImaxS, JminS, JmaxS, &
2700!^ & krhs, kstp, knew, &
2701!^ & ubar, vbar, zeta)
2702!^
2703 CALL tl_u2dbc_tile (ng, tile, &
2704 & lbi, ubi, lbj, ubj, &
2705 & imins, imaxs, jmins, jmaxs, &
2706 & krhs, kstp, knew, &
2707 & ubar, vbar, zeta, &
2708 & tl_ubar, tl_vbar, tl_zeta)
2709!^ CALL v2dbc_tile (ng, tile, &
2710!^ & LBi, UBi, LBj, UBj, &
2711!^ & IminS, ImaxS, JminS, JmaxS, &
2712!^ & krhs, kstp, knew, &
2713!^ & ubar, vbar, zeta)
2714!^
2715 CALL tl_v2dbc_tile (ng, tile, &
2716 & lbi, ubi, lbj, ubj, &
2717 & imins, imaxs, jmins, jmaxs, &
2718 & krhs, kstp, knew, &
2719 & ubar, vbar, zeta, &
2720 & tl_ubar, tl_vbar, tl_zeta)
2721!
2722! Compute integral mass flux across open boundaries and adjust
2723! for volume conservation.
2724!
2725 IF (any(volcons(:,ng))) THEN
2726!^ CALL obc_flux_tile (ng, tile, &
2727!^ & LBi, UBi, LBj, UBj, &
2728!^ & IminS, ImaxS, JminS, JmaxS, &
2729!^ & knew, &
2730#ifdef MASKING
2731!^ & umask, vmask, &
2732#endif
2733!^ & h, om_v, on_u, &
2734!^ & ubar, vbar, zeta)
2735!^
2736 CALL tl_obc_flux_tile (ng, tile, &
2737 & lbi, ubi, lbj, ubj, &
2738 & imins, imaxs, jmins, jmaxs, &
2739 & knew, &
2740#ifdef MASKING
2741 & umask, vmask, &
2742#endif
2743 & h, tl_h, om_v, on_u, &
2744 & ubar, vbar, zeta, &
2745 & tl_ubar, tl_vbar, tl_zeta)
2746 END IF
2747
2748#if defined SOLVE3D || (defined NESTING && !defined SOLVE3D)
2749!
2750! Set barotropic fluxes along physical boundaries.
2751!
2752 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2753 IF (domain(ng)%Western_Edge(tile)) THEN
2754 DO j=jstr-1,jendr
2755!^ Dnew(Istr-1,j)=h(Istr-1,j)+zeta_new(Istr-1,j)
2756!^
2757 tl_dnew(istr-1,j)=tl_h(istr-1,j)+tl_zeta_new(istr-1,j)
2758 END DO
2759 END IF
2760 END IF
2761 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2762 IF (domain(ng)%Eastern_Edge(tile)) THEN
2763 DO j=jstr-1,jendr
2764!^ Dnew(Iend+1,j)=h(Iend+1,j)+zeta_new(Iend+1,j)
2765!^
2766 tl_dnew(iend+1,j)=tl_h(iend+1,j)+tl_zeta_new(iend+1,j)
2767 END DO
2768 END IF
2769 END IF
2770 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2771 IF (domain(ng)%Southern_Edge(tile)) THEN
2772 DO i=istr-1,iendr
2773!^ Dnew(i,Jstr-1)=h(i,Jstr-1)+zeta_new(i,Jstr-1)
2774!^
2775 tl_dnew(i,jstr-1)=tl_h(i,jstr-1)+tl_zeta_new(i,jstr-1)
2776 END DO
2777 END IF
2778 END IF
2779 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2780 IF (domain(ng)%Northern_Edge(tile)) THEN
2781 DO i=istr-1,iendr
2782!^ Dnew(i,Jend+1)=h(i,Jend+1)+zeta_new(i,Jend+1)
2783!^
2784 tl_dnew(i,jend+1)=tl_h(i,jend+1)+tl_zeta_new(i,jend+1)
2785 END DO
2786 END IF
2787 END IF
2788
2789# ifdef SOLVE3D
2790!
2791 cff1=0.5*weight(1,iif(ng),ng)
2792# endif
2793!
2794 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
2795 IF (domain(ng)%Western_Edge(tile)) THEN
2796 DO j=jstrr,jendr
2797# if defined NESTING && !defined SOLVE3D
2798!^ DU_flux(IstrU-1,j)=0.5_r8*on_u(IstrU-1,j)* &
2799!^ & (Dnew(IstrU-1,j)+Dnew(IstrU-2,j))* &
2800!^ & ubar(IstrU-1,j,knew)
2801!^
2802 tl_du_flux(istru-1,j)=0.5_r8*on_u(istru-1,j)* &
2803 & ((dnew(istru-1,j)+ &
2804 & dnew(istru-2,j))* &
2805 & tl_ubar(istru-1,j,knew)+ &
2806 & (tl_dnew(istru-1,j)+ &
2807 & tl_dnew(istru-2,j))* &
2808 & ubar(istru-1,j,knew))
2809# else
2810!^ DU_avg1(IstrU-1,j)=DU_avg1(IstrU-1,j)+ &
2811!^ & cff1*on_u(IstrU-1,j)* &
2812!^ & (Dnew(IstrU-1,j)+Dnew(IstrU-2,j))* &
2813!^ & ubar(IstrU-1,j,knew)
2814!^
2815 tl_du_avg1(istru-1,j)=tl_du_avg1(istru-1,j)+ &
2816 & cff1*on_u(istru-1,j)* &
2817 & ((dnew(istru-1,j)+ &
2818 & dnew(istru-2,j))* &
2819 & tl_ubar(istru-1,j,knew)+ &
2820 & (tl_dnew(istru-1,j)+ &
2821 & tl_dnew(istru-2,j))* &
2822 & ubar(istru-1,j,knew))
2823# endif
2824 END DO
2825 DO j=jstrv,jend
2826# if defined NESTING && !defined SOLVE3D
2827!^ DV_flux(Istr-1,j)=0.5_r8*om_v(Istr-1,j)* &
2828!^ & (Dnew(Istr-1,j)+Dnew(Istr-1,j-1))* &
2829!^ & vbar(Istr-1,j,knew)
2830!^
2831 tl_dv_flux(istr-1,j)=0.5_r8*om_v(istr-1,j)* &
2832 & ((dnew(istr-1,j )+ &
2833 & dnew(istr-1,j-1))* &
2834 & tl_vbar(istr-1,j,knew)+ &
2835 & (tl_dnew(istr-1,j )+ &
2836 & tl_dnew(istr-1,j-1))* &
2837 & vbar(istr-1,j,knew))
2838# else
2839!^ DV_avg1(Istr-1,j)=DV_avg1(Istr-1,j)+ &
2840!^ & cff1*om_v(Istr-1,j)* &
2841!^ & (Dnew(Istr-1,j)+Dnew(Istr-1,j-1))* &
2842!^ & vbar(Istr-1,j,knew)
2843!^
2844 tl_dv_avg1(istr-1,j)=tl_dv_avg1(istr-1,j)+ &
2845 & cff1*om_v(istr-1,j)* &
2846 & ((dnew(istr-1,j )+ &
2847 & dnew(istr-1,j-1))* &
2848 & tl_vbar(istr-1,j,knew)+ &
2849 & (tl_dnew(istr-1,j )+ &
2850 & tl_dnew(istr-1,j-1))* &
2851 & vbar(istr-1,j,knew))
2852# endif
2853 END DO
2854 END IF
2855 END IF
2856 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
2857 IF (domain(ng)%Eastern_Edge(tile)) THEN
2858 DO j=jstrr,jendr
2859# if defined NESTING && !defined SOLVE3D
2860!^ DU_flux(Iend+1,j)=0.5_r8*on_u(Iend+1,j)* &
2861!^ & (Dnew(Iend+1,j)+Dnew(Iend,j))* &
2862!^ & ubar(Iend+1,j,knew)
2863!^
2864 tl_du_flux(iend+1,j)=0.5_r8*on_u(iend+1,j)* &
2865 & ((dnew(iend+1,j)+ &
2866 & dnew(iend ,j))* &
2867 & tl_ubar(iend+1,j,knew)+ &
2868 & (tl_dnew(iend+1,j)+ &
2869 & tl_dnew(iend ,j))* &
2870 & ubar(iend+1,j,knew))
2871# else
2872!^ DU_avg1(Iend+1,j)=DU_avg1(Iend+1,j)+ &
2873!^ & cff1*on_u(Iend+1,j)* &
2874!^ & (Dnew(Iend+1,j)+Dnew(Iend,j))* &
2875!^ & ubar(Iend+1,j,knew)
2876!^
2877 tl_du_avg1(iend+1,j)=tl_du_avg1(iend+1,j)+ &
2878 & cff1*on_u(iend+1,j)* &
2879 & ((dnew(iend+1,j)+ &
2880 & dnew(iend ,j))* &
2881 & tl_ubar(iend+1,j,knew)+ &
2882 & (tl_dnew(iend+1,j)+ &
2883 & tl_dnew(iend ,j))* &
2884 & ubar(iend+1,j,knew))
2885# endif
2886 END DO
2887 DO j=jstrv,jend
2888# if defined NESTING && !defined SOLVE3D
2889!^ DV_flux(Iend+1,j)=0.5_r8*om_v(Iend+1,j)* &
2890!^ & (Dnew(Iend+1,j)+Dnew(Iend+1,j-1))* &
2891!^ & vbar(Iend+1,j,knew)
2892!^
2893 tl_dv_flux(iend+1,j)=0.5_r8*om_v(iend+1,j)* &
2894 & ((dnew(iend+1,j )+ &
2895 & dnew(iend+1,j-1))* &
2896 & tl_vbar(iend+1,j,knew)+ &
2897 & (tl_dnew(iend+1,j )+ &
2898 & tl_dnew(iend+1,j-1))* &
2899 & vbar(iend+1,j,knew))
2900# else
2901!^ DV_avg1(Iend+1,j)=DV_avg1(Iend+1,j)+ &
2902!^ & cff1*om_v(Iend+1,j)* &
2903!^ & (Dnew(Iend+1,j)+Dnew(Iend+1,j-1))* &
2904!^ & vbar(Iend+1,j,knew)
2905!^
2906 tl_dv_avg1(iend+1,j)=tl_dv_avg1(iend+1,j)+ &
2907 & cff1*om_v(iend+1,j)* &
2908 & ((dnew(iend+1,j )+ &
2909 & dnew(iend+1,j-1))* &
2910 & tl_vbar(iend+1,j,knew)+ &
2911 & (tl_dnew(iend+1,j )+ &
2912 & tl_dnew(iend+1,j-1))* &
2913 & vbar(iend+1,j,knew))
2914# endif
2915 END DO
2916 END IF
2917 END IF
2918 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
2919 IF (domain(ng)%Southern_Edge(tile)) THEN
2920 DO i=istru,iend
2921# if defined NESTING && !defined SOLVE3D
2922!^ DU_flux(i,Jstr-1)=0.5_r8*on_u(i,Jstr-1)* &
2923!^ & (Dnew(i,Jstr-1)+Dnew(i-1,Jstr-1))* &
2924!^ & ubar(i,Jstr-1,knew)
2925!^
2926 tl_du_flux(i,jstr-1)=0.5_r8*on_u(i,jstr-1)* &
2927 & ((dnew(i ,jstr-1)+ &
2928 & dnew(i-1,jstr-1))* &
2929 & tl_ubar(i,jstr-1,knew)+ &
2930 & (tl_dnew(i ,jstr-1)+ &
2931 & tl_dnew(i-1,jstr-1))* &
2932 & ubar(i,jstr-1,knew))
2933# else
2934!^ DU_avg1(i,Jstr-1)=DU_avg1(i,Jstr-1)+ &
2935!^ & cff1*on_u(i,Jstr-1)* &
2936!^ & (Dnew(i,Jstr-1)+Dnew(i-1,Jstr-1))* &
2937!^ & ubar(i,Jstr-1,knew)
2938!^
2939 tl_du_avg1(i,jstr-1)=tl_du_avg1(i,jstr-1)+ &
2940 & cff1*on_u(i,jstr-1)* &
2941 & ((dnew(i ,jstr-1)+ &
2942 & dnew(i-1,jstr-1))* &
2943 & tl_ubar(i,jstr-1,knew)+ &
2944 & (tl_dnew(i ,jstr-1)+ &
2945 & tl_dnew(i-1,jstr-1))* &
2946 & ubar(i,jstr-1,knew))
2947# endif
2948 END DO
2949 DO i=istrr,iendr
2950# if defined NESTING && !defined SOLVE3D
2951!^ DV_flux(i,JstrV-1)=0.5_r8*om_v(i,JstrV-1)* &
2952!^ & (Dnew(i,JstrV-1)+Dnew(i,JstrV-2))* &
2953!^ & vbar(i,JstrV-1,knew)
2954!^
2955 tl_dv_flux(i,jstrv-1)=0.5_r8*om_v(i,jstrv-1)* &
2956 & ((dnew(i,jstrv-1)+ &
2957 & dnew(i,jstrv-2))* &
2958 & tl_vbar(i,jstrv-1,knew)+ &
2959 & (tl_dnew(i,jstrv-1)+ &
2960 & tl_dnew(i,jstrv-2))* &
2961 & vbar(i,jstrv-1,knew))
2962# else
2963!^ DV_avg1(i,JstrV-1)=DV_avg1(i,JstrV-1)+ &
2964!^ & cff1*om_v(i,JstrV-1)* &
2965!^ & (Dnew(i,JstrV-1)+Dnew(i,JstrV-2))* &
2966!^ & vbar(i,JstrV-1,knew)
2967!^
2968 tl_dv_avg1(i,jstrv-1)=tl_dv_avg1(i,jstrv-1)+ &
2969 & cff1*om_v(i,jstrv-1)* &
2970 & ((dnew(i,jstrv-1)+ &
2971 & dnew(i,jstrv-2))* &
2972 & tl_vbar(i,jstrv-1,knew)+ &
2973 & (tl_dnew(i,jstrv-1)+ &
2974 & tl_dnew(i,jstrv-2))* &
2975 & vbar(i,jstrv-1,knew))
2976# endif
2977 END DO
2978 END IF
2979 END IF
2980 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
2981 IF (domain(ng)%Northern_Edge(tile)) THEN
2982 DO i=istru,iend
2983# if defined NESTING && !defined SOLVE3D
2984!^ DU_flux(i,Jend+1)=0.5_r8*on_u(i,Jend+1)* &
2985!^ & (Dnew(i,Jend+1)+Dnew(i-1,Jend+1))* &
2986!^ & ubar(i,Jend+1,knew)
2987!^
2988 tl_du_flux(i,jend+1)=0.5_r8*on_u(i,jend+1)* &
2989 & ((dnew(i ,jend+1)+ &
2990 & dnew(i-1,jend+1))* &
2991 & tl_ubar(i,jend+1,knew)+ &
2992 & (tl_dnew(i ,jend+1)+ &
2993 & tl_dnew(i-1,jend+1))* &
2994 & ubar(i,jend+1,knew))
2995# else
2996!^ DU_avg1(i,Jend+1)=DU_avg1(i,Jend+1)+ &
2997!^ & cff1*on_u(i,Jend+1)* &
2998!^ & (Dnew(i,Jend+1)+Dnew(i-1,Jend+1))* &
2999!^ & ubar(i,Jend+1,knew)
3000!^
3001 tl_du_avg1(i,jend+1)=tl_du_avg1(i,jend+1)+ &
3002 & cff1*on_u(i,jend+1)* &
3003 & ((dnew(i ,jend+1)+ &
3004 & dnew(i-1,jend+1))* &
3005 & tl_ubar(i,jend+1,knew)+ &
3006 & (tl_dnew(i ,jend+1)+ &
3007 & tl_dnew(i-1,jend+1))* &
3008 & ubar(i,jend+1,knew))
3009# endif
3010 END DO
3011 DO i=istrr,iendr
3012# if defined NESTING && !defined SOLVE3D
3013!^ DV_flux(i,Jend+1)=0.5_r8*om_v(i,Jend+1)* &
3014!^ & (Dnew(i,Jend+1)+Dnew(i,Jend))* &
3015!^ & vbar(i,Jend+1,knew)
3016!^
3017 tl_dv_flux(i,jend+1)=0.5_r8*om_v(i,jend+1)* &
3018 & ((dnew(i,jend+1)+ &
3019 & dnew(i,jend ))* &
3020 & tl_vbar(i,jend+1,knew)+ &
3021 & (tl_dnew(i,jend+1)+ &
3022 & tl_dnew(i,jend ))* &
3023 & vbar(i,jend+1,knew))
3024# else
3025!^ DV_avg1(i,Jend+1)=DV_avg1(i,Jend+1)+ &
3026!^ & cff1*om_v(i,Jend+1)* &
3027!^ & (Dnew(i,Jend+1)+Dnew(i,Jend))* &
3028!^ & vbar(i,Jend+1,knew)
3029!^
3030 tl_dv_avg1(i,jend+1)=tl_dv_avg1(i,jend+1)+ &
3031 & cff1*om_v(i,jend+1)* &
3032 & ((dnew(i,jend+1)+ &
3033 & dnew(i,jend ))* &
3034 & tl_vbar(i,jend+1,knew)+ &
3035 & (tl_dnew(i,jend+1)+ &
3036 & tl_dnew(i,jend ))* &
3037 & vbar(i,jend+1,knew))
3038# endif
3039 END DO
3040 END IF
3041 END IF
3042#endif
3043!
3044!-----------------------------------------------------------------------
3045! Apply momentum transport point sources (like river runoff), if any.
3046!
3047! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
3048! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
3049!-----------------------------------------------------------------------
3050!
3051 IF (luvsrc(ng)) THEN
3052 DO is=1,nsrc(ng)
3053 i=sources(ng)%Isrc(is)
3054 j=sources(ng)%Jsrc(is)
3055 IF (((istrr.le.i).and.(i.le.iendr)).and. &
3056 & ((jstrr.le.j).and.(j.le.jendr))) THEN
3057 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
3058 cff=1.0_r8/(on_u(i,j)* &
3059 & 0.5_r8*(dnew(i-1,j)+dnew(i,j)))
3060 tl_cff=-cff*cff*on_u(i,j)* &
3061 & 0.5_r8*(tl_dnew(i-1,j)+tl_dnew(i ,j))
3062!^ ubar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3063!^
3064 tl_ubar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3065 & sources(ng)%Qbar(is)*tl_cff
3066#ifdef SOLVE3D
3067!^ DU_avg1(i,j)=SOURCES(ng)%Qbar(is)
3068!^
3069 tl_du_avg1(i,j)=sources(ng)%tl_Qbar(is)
3070#endif
3071#if defined NESTING && !defined SOLVE3D
3072!^ DU_flux(i,j)=SOURCES(ng)%Qbar(is)
3073!^
3074 tl_du_flux(i,j)=sources(ng)%tl_Qbar(is)
3075#endif
3076 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
3077 cff=1.0_r8/(om_v(i,j)* &
3078 & 0.5_r8*(dnew(i,j-1)+dnew(i,j)))
3079 tl_cff=-cff*cff*om_v(i,j)* &
3080 & 0.5_r8*(tl_dnew(i,j-1)+tl_dnew(i,j))
3081!^ vbar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3082!^
3083 tl_vbar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3084 & sources(ng)%Qbar(is)*tl_cff
3085#ifdef SOLVE3D
3086!^ DV_avg1(i,j)=SOURCES(ng)%Qbar(is)
3087!^
3088 tl_dv_avg1(i,j)=sources(ng)%tl_Qbar(is)
3089#endif
3090#if defined NESTING && !defined SOLVE3D
3091!^ DV_flux(i,j)=SOURCES(ng)%Qbar(is)
3092!^
3093 tl_dv_flux(i,j)=sources(ng)%tl_Qbar(is)
3094#endif
3095 END IF
3096 END IF
3097 END DO
3098 END IF
3099!
3100! Deallocate local new free-surface.
3101!
3102 deallocate ( tl_zeta_new )
3103
3104#ifdef WET_DRY_NOT_YET
3105!
3106!-----------------------------------------------------------------------
3107! Compute new wet/dry masks.
3108!-----------------------------------------------------------------------
3109!
3110!^ CALL wetdry_tile (ng, tile, &
3111!^ & LBi, UBi, LBj, UBj, &
3112!^ & IminS, ImaxS, JminS, JmaxS, &
3113# ifdef MASKING
3114!^ & pmask, rmask, umask, vmask, &
3115# endif
3116!^ & h, zeta(:,:,knew), &
3117# ifdef SOLVE3D
3118!^ & DU_avg1, DV_avg1, &
3119!^ & rmask_wet_avg, &
3120# endif
3121!^ & pmask_wet, pmask_full, &
3122!^ & rmask_wet, rmask_full, &
3123!^ & umask_wet, umask_full, &
3124!^ & vmask_wet, vmask_full)
3125!^
3126!^ HGA: Need the TLM code here.
3127!^
3128#endif
3129
3130#ifdef SOLVE3D
3131!
3132!-----------------------------------------------------------------------
3133! At the end of the last 2D time step replace the new free-surface
3134! zeta(:,:,knew) with it fast time-averaged value, Zt_avg1. Recall
3135! this is state variable is the one that communicates with the 3D
3136! kernel. Compute time-dependent depths.
3137!-----------------------------------------------------------------------
3138!
3139 IF (iif(ng).eq.nfast(ng)) THEN
3140 DO j=jstrr,jendr
3141 DO i=istrr,iendr
3142!^ zeta(i,j,knew)=Zt_avg1(i,j)
3143!^
3144 tl_zeta(i,j,knew)=tl_zt_avg1(i,j)
3145 END DO
3146 END DO
3147!^ CALL set_depth (ng, tile, iNLM)
3148!^
3149 CALL tl_set_depth (ng, tile, itlm)
3150 END IF
3151#endif
3152
3153#ifdef NESTING
3154# ifdef SOLVE3D
3155!
3156!-----------------------------------------------------------------------
3157! If nesting and after all fast time steps are completed, exchange
3158! halo information to time averaged fields.
3159!-----------------------------------------------------------------------
3160!
3161 IF (iif(ng).eq.nfast(ng)) THEN
3162!
3163! In nesting applications with refinement grids, we need to exchange
3164! the DU_avg2 and DV_avg2 fluxes boundary information for the case
3165! that a contact point is at a tile partition. Notice that in such
3166! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3167!
3168 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3169!^ CALL exchange_r2d_tile (ng, tile, &
3170!^ & LBi, UBi, LBj, UBj, &
3171!^ & Zt_avg1)
3172!^
3173 CALL exchange_r2d_tile (ng, tile, &
3174 & lbi, ubi, lbj, ubj, &
3175 & tl_zt_avg1)
3176!^ CALL exchange_u2d_tile (ng, tile, &
3177!^ & LBi, UBi, LBj, UBj, &
3178!^ & DU_avg1)
3179!^
3180 CALL exchange_u2d_tile (ng, tile, &
3181 & lbi, ubi, lbj, ubj, &
3182 & tl_du_avg1)
3183!^ CALL exchange_v2d_tile (ng, tile, &
3184!^ & LBi, UBi, LBj, UBj, &
3185!^ & DV_avg1)
3186!^
3187 CALL exchange_v2d_tile (ng, tile, &
3188 & lbi, ubi, lbj, ubj, &
3189 & tl_dv_avg1)
3190!^ CALL exchange_u2d_tile (ng, tile, &
3191!^ & LBi, UBi, LBj, UBj, &
3192!^ & DU_avg2)
3193!^
3194 CALL exchange_u2d_tile (ng, tile, &
3195 & lbi, ubi, lbj, ubj, &
3196 & tl_du_avg2)
3197!^ CALL exchange_v2d_tile (ng, tile, &
3198!^ & LBi, UBi, LBj, UBj, &
3199!^ & DV_avg2)
3200!^
3201 CALL exchange_v2d_tile (ng, tile, &
3202 & lbi, ubi, lbj, ubj, &
3203 & tl_dv_avg2)
3204 END IF
3205
3206# ifdef DISTRIBUTE
3207!
3208!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3209!^ & LBi, UBi, LBj, UBj, &
3210!^ & NghostPoints, &
3211!^ & EWperiodic(ng), NSperiodic(ng), &
3212!^ & Zt_avg1, DU_avg1, DV_avg1)
3213!^
3214 CALL mp_exchange2d (ng, tile, itlm, 3, &
3215 & lbi, ubi, lbj, ubj, &
3216 & nghostpoints, &
3217 & ewperiodic(ng), nsperiodic(ng), &
3218 & tl_zt_avg1, tl_du_avg1, tl_dv_avg1)
3219!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3220!^ & LBi, UBi, LBj, UBj, &
3221!^ & NghostPoints, &
3222!^ & EWperiodic(ng), NSperiodic(ng), &
3223!^ & DU_avg2, DV_avg2)
3224!^
3225 CALL mp_exchange2d (ng, tile, itlm, 2, &
3226 & lbi, ubi, lbj, ubj, &
3227 & nghostpoints, &
3228 & ewperiodic(ng), nsperiodic(ng), &
3229 & tl_du_avg2, tl_dv_avg2)
3230# endif
3231 END IF
3232# else
3233!
3234! In nesting applications with refinement grids, we need to exchange
3235! the DU_flux and DV_flux fluxes boundary information for the case
3236! that a contact point is at a tile partition. Notice that in such
3237! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3238!
3239 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3240!^ CALL exchange_u2d_tile (ng, tile, &
3241!^ & LBi, UBi, LBj, UBj, &
3242!^ & DU_flux)
3243!^
3244 CALL exchange_u2d_tile (ng, tile, &
3245 & lbi, ubi, lbj, ubj, &
3246 & tl_du_flux)
3247!^ CALL exchange_v2d_tile (ng, tile, &
3248!^ & LBi, UBi, LBj, UBj, &
3249!^ & DV_flux)
3250!^
3251 CALL exchange_v2d_tile (ng, tile, &
3252 & lbi, ubi, lbj, ubj, &
3253 & tl_dv_flux)
3254 END IF
3255
3256# ifdef DISTRIBUTE
3257!
3258!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3259!^ & LBi, UBi, LBj, UBj, &
3260!^ & NghostPoints, &
3261!^ & EWperiodic(ng), NSperiodic(ng), &
3262!^ & DU_flux, DV_flux)
3263!^
3264 CALL mp_exchange2d (ng, tile, itlm, 2, &
3265 & lbi, ubi, lbj, ubj, &
3266 & nghostpoints, &
3267 & ewperiodic(ng), nsperiodic(ng), &
3268 & tl_du_flux, tl_dv_flux)
3269# endif
3270# endif
3271#endif
3272!
3273!-----------------------------------------------------------------------
3274! Exchange halo tile information.
3275!-----------------------------------------------------------------------
3276!
3277 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3278!^ CALL exchange_r2d_tile (ng, tile, &
3279!^ & LBi, UBi, LBj, UBj, &
3280!^ & zeta(:,:,knew))
3281!^
3282 CALL exchange_r2d_tile (ng, tile, &
3283 & lbi, ubi, lbj, ubj, &
3284 & tl_zeta(:,:,knew))
3285!^ CALL exchange_u2d_tile (ng, tile, &
3286!^ & LBi, UBi, LBj, UBj, &
3287!^ & ubar(:,:,knew))
3288!^
3289 CALL exchange_u2d_tile (ng, tile, &
3290 & lbi, ubi, lbj, ubj, &
3291 & tl_ubar(:,:,knew))
3292!^ CALL exchange_v2d_tile (ng, tile, &
3293!^ & LBi, UBi, LBj, UBj, &
3294!^ & vbar(:,:,knew))
3295!^
3296 CALL exchange_v2d_tile (ng, tile, &
3297 & lbi, ubi, lbj, ubj, &
3298 & tl_vbar(:,:,knew))
3299 END IF
3300
3301#ifdef DISTRIBUTE
3302!
3303!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3304!^ & LBi, UBi, LBj, UBj, &
3305!^ & NghostPoints, &
3306!^ & EWperiodic(ng), NSperiodic(ng), &
3307!^ & zeta(:,:,knew), &
3308!^ & ubar(:,:,knew), &
3309!^ & vbar(:,:,knew))
3310!^
3311 CALL mp_exchange2d (ng, tile, itlm, 3, &
3312 & lbi, ubi, lbj, ubj, &
3313 & nghostpoints, &
3314 & ewperiodic(ng), nsperiodic(ng), &
3315 & tl_zeta(:,:,knew), &
3316 & tl_ubar(:,:,knew), &
3317 & tl_vbar(:,:,knew))
3318#endif
3319!
3320 RETURN

References mod_scalars::compositegrid, mod_param::domain, mod_scalars::dtfast, mod_scalars::ewperiodic, exchange_2d_mod::exchange_r2d_tile(), exchange_2d_mod::exchange_u2d_tile(), exchange_2d_mod::exchange_v2d_tile(), mod_scalars::g, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_scalars::inorth, mod_scalars::isouth, mod_param::itlm, mod_scalars::iwest, mod_scalars::luvsrc, mod_scalars::lwsrc, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, mod_scalars::ntstart, obc_volcons_mod::obc_flux_tile(), mod_scalars::rho0, obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, tl_obc_volcons_mod::tl_obc_flux_tile(), tl_set_depth_mod::tl_set_depth(), tl_obc_volcons_mod::tl_set_duv_bc_tile(), tl_u2dbc_mod::tl_u2dbc_tile(), tl_v2dbc_mod::tl_v2dbc_tile(), mod_scalars::volcons, and mod_scalars::weight.

Referenced by tl_step2d().

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