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

Functions/Subroutines

subroutine, public rp_step2d (ng, tile)
 
subroutine rp_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 rp_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 rp_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_sustr, tl_svstr, 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

◆ rp_step2d()

subroutine public rp_step2d_mod::rp_step2d ( integer, intent(in) ng,
integer, intent(in) tile )

Definition at line 76 of file rp_step2d_FB.h.

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

Referenced by rp_main3d().

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

◆ rp_step2d_tile() [1/3]

subroutine rp_step2d_mod::rp_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 rp_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#ifdef TL_IOMS
716 & duon(i,j)
717#endif
718 END DO
719 END DO
720 DO j=jv_range
721 DO i=iv_range
722 cff=0.5_r8*om_v(i,j)
723 cff1=cff*(drhs(i,j)+drhs(i,j-1))
724 tl_cff1=cff*(tl_drhs(i,j)+tl_drhs(i,j-1))
725 dvom(i,j)=vbar(i,j,krhs)*cff1
726 tl_dvom(i,j)=tl_vbar(i,j,krhs)*cff1+ &
727 & vbar(i,j,krhs)*tl_cff1- &
728#ifdef TL_IOMS
729 & dvom(i,j)
730#endif
731 END DO
732 END DO
733
734#undef IR_RANGE
735#undef IU_RANGE
736#undef IV_RANGE
737#undef JR_RANGE
738#undef JU_RANGE
739#undef JV_RANGE
740
741#if defined DISTRIBUTE && \
742 defined uv_adv && defined uv_c4advection && !defined SOLVE3D
743!
744! In distributed-memory, the I- and J-ranges are different and a
745! special exchange is done here to avoid having three ghost points
746! for high-order numerical stencils. Notice that a private array is
747! passed below to the exchange routine. It also applies periodic
748! boundary conditions, if appropriate and no partitions in I- or
749! J-directions.
750!
751 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
752 CALL exchange_u2d_tile (ng, tile, &
753 & imins, imaxs, jmins, jmaxs, &
754 & duon)
755 CALL exchange_u2d_tile (ng, tile, &
756 & imins, imaxs, jmins, jmaxs, &
757 & tl_duon)
758 CALL exchange_v2d_tile (ng, tile, &
759 & imins, imaxs, jmins, jmaxs, &
760 & dvom)
761 CALL exchange_v2d_tile (ng, tile, &
762 & imins, imaxs, jmins, jmaxs, &
763 & tl_dvom)
764 END IF
765 CALL mp_exchange2d (ng, tile, irpm, 4, &
766 & imins, imaxs, jmins, jmaxs, &
767 & nghostpoints, &
768 & ewperiodic(ng), nsperiodic(ng), &
769 & duon, dvom, &
770 & tl_duon, tl_dvom)
771#endif
772!
773! Compute integral mass flux across open boundaries and adjust
774! for volume conservation. Compute BASIC STATE value.
775!
776 IF (any(volcons(:,ng))) THEN
777 CALL obc_flux_tile (ng, tile, &
778 & lbi, ubi, lbj, ubj, &
779 & imins, imaxs, jmins, jmaxs, &
780 & knew, &
781#ifdef MASKING
782 & umask, vmask, &
783#endif
784 & h, om_v, on_u, &
785 & ubar, vbar, zeta)
786!
787! Set vertically integrated mass fluxes DUon and DVom along the open
788! boundaries in such a way that the integral volume is conserved.
789!
790 CALL set_duv_bc_tile (ng, tile, &
791 & lbi, ubi, lbj, ubj, &
792 & imins, imaxs, jmins, jmaxs, &
793 & krhs, &
794#ifdef MASKING
795 & umask, vmask, &
796#endif
797 & om_v, on_u, &
798 & ubar, vbar, &
799 & drhs, duon, dvom)
800 CALL rp_set_duv_bc_tile (ng, tile, &
801 & lbi, ubi, lbj, ubj, &
802 & imins, imaxs, jmins, jmaxs, &
803 & krhs, &
804#ifdef MASKING
805 & umask, vmask, &
806#endif
807 & om_v, on_u, &
808 & ubar, vbar, &
809 & tl_ubar, tl_vbar, &
810 & drhs, duon, dvom, &
811 & tl_drhs, tl_duon, tl_dvom)
812 END IF
813
814#ifdef SOLVE3D
815!
816!-----------------------------------------------------------------------
817! Fields averaged over all barotropic time steps.
818!-----------------------------------------------------------------------
819!
820! Notice that the index ranges here are designed to include physical
821! boundaries only. Periodic ghost points and internal mpi computational
822! margins are NOT included.
823!
824! Reset all barotropic mode time-averaged arrays during the first
825! predictor step. At all subsequent time steps, accumulate averages
826! of the first kind using the DELAYED way. For example, "Zt_avg1" is
827! not summed immediately after the corrector step when computed but
828! during the subsequent predictor substep. It allows saving operations
829! because "DUon" and "DVom" are calculated anyway. The last time step
830! has a special code to add all three barotropic variables after the
831! last corrector substep.
832!
833 IF (predictor_2d_step) THEN ! PREDICTOR STEP
834 IF (first_2d_step) THEN
835 DO j=jstrr,jendr
836 DO i=istrr,iendr
837!^ Zt_avg1(i,j)=0.0_r8
838!^
839 tl_zt_avg1(i,j)=0.0_r8
840!^ DU_avg1(i,j)=0.0_r8
841!^
842 tl_du_avg1(i,j)=0.0_r8
843!^ DV_avg1(i,j)=0.0_r8
844!^
845 tl_dv_avg1(i,j)=0.0_r8
846!^ DU_avg2(i,j)=0.0_r8
847!^
848 tl_du_avg2(i,j)=0.0_r8
849!^ DV_avg2(i,j)=0.0_r8
850!^
851 tl_dv_avg2(i,j)=0.0_r8
852 END DO
853 END DO
854 ELSE
855 cff=weight(1,iif(ng)-1,ng)
856 DO j=jstrr,jendr
857 DO i=istrr,iendr
858!^ Zt_avg1(i,j)=Zt_avg1(i,j)+cff*zeta(i,j,krhs)
859!^
860 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+cff*tl_zeta(i,j,krhs)
861 IF (i.ge.istr) THEN
862!^ DU_avg1(i,j)=DU_avg1(i,j)+cff*DUon(i,j)
863!^
864 tl_du_avg1(i,j)=tl_du_avg1(i,j)+cff*tl_duon(i,j)
865 END IF
866 IF (j.ge.jstr) THEN
867!^ DV_avg1(i,j)=DV_avg1(i,j)+cff*DVom(i,j)
868!^
869 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+cff*tl_dvom(i,j)
870 END IF
871 END DO
872 END DO
873 END IF
874 ELSE ! CORRECTOR STEP
875 cff=weight(2,iif(ng),ng)
876 DO j=jstrr,jendr
877 DO i=istrr,iendr
878 IF (i.ge.istr) THEN
879!^ DU_avg2(i,j)=DU_avg2(i,j)+cff*DUon(i,j)
880!^
881 tl_du_avg2(i,j)=tl_du_avg2(i,j)+cff*tl_duon(i,j)
882 END IF
883 IF (j.ge.jstr) THEN
884!^ DV_avg2(i,j)=DV_avg2(i,j)+cff*DVom(i,j)
885!^
886 tl_dv_avg2(i,j)=tl_dv_avg2(i,j)+cff*tl_dvom(i,j)
887 END IF
888 END DO
889 END DO
890 END IF
891#endif
892!
893!-----------------------------------------------------------------------
894! Tangent linear of advance free-surface.
895!-----------------------------------------------------------------------
896!
897! Notice that the new local free-surface is allocated so it can be
898! passed as an argumment to "zetabc" to avoid memory issues.
899!
900 allocate ( tl_zeta_new(imins:imaxs,jmins:jmaxs) )
901 tl_zeta_new = 0.0_r8
902!
903! Get background "zeta_new" from BASIC state. Notice the I- and J-range
904! used to avoid calling nonlinear 'zetabc_local' routine.
905!
906 DO j=lbj,ubj
907 DO i=lbi,ubi
908 zeta_new(i,j)=zeta(i,j,knew)
909#ifdef MASKING
910 zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
911# ifdef WET_DRY_NOT_YET
912!! zeta_new(i,j)=zeta_new(i,j)+ &
913!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
914# endif
915#endif
916 dnew(i,j)=h(i,j)+zeta_new(i,j)
917 dstp(i,j)=h(i,j)+zeta(i,j,kstp)
918 END DO
919 END DO
920!
921! Compute "zeta_new" at the new time step and interpolate backward for
922! the subsequent computation of barotropic pressure-gradient terms.
923! Notice that during the predictor of the first 2D step in 3D mode,
924! the pressure gradient terms are computed using just zeta(:,:,kstp),
925! i.e., like in the Forward Euler step, rather than the more accurate
926! predictor of generalized RK2. This is to keep it consistent with the
927! computation of pressure gradient in 3D mode, which uses precisely
928! the initial value of "zeta" rather than the value changed by the
929! first barotropic predictor step. Later in this code, just after
930! "rufrc, rvfrc" are finalized, a correction term based on the
931! difference zeta_new(:,:)-zeta(:,:,kstp) to "rubar, rvbar" to make
932! them consistent with generalized RK2 stepping for pressure gradient
933! terms.
934!
935 IF (predictor_2d_step) THEN
936 IF (first_2d_step) THEN ! Modified RK2 time step (with
937 cff=dtfast(ng) ! Forward-Backward feedback with
938#ifdef SOLVE3D
939 cff1=0.0_r8 !==> Forward Euler
940 cff2=1.0_r8
941#else
942 cff1=0.333333333333_r8 ! optimally chosen beta=1/3 and
943 cff2=0.666666666667_r8 ! epsilon=2/3, see below) is used
944#endif
945 cff3=0.0_r8 ! here for the start up.
946 ELSE
947 cff=2.0_r8*dtfast(ng) ! In the code below "zwrk" is
948 cff1=beta ! time-centered at time step "n"
949 cff2=1.0_r8-2.0_r8*beta ! in the case of LF (for all but
950 cff3=beta ! the first time step)
951 END IF
952!
953 DO j=jstrv-1,jend
954 DO i=istru-1,iend
955 fac=cff*pm(i,j)*pn(i,j)
956!^ zeta_new(i,j)=zeta(i,j,kbak)+ &
957!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
958!^ & DVom(i,j)-DVom(i,j+1))
959!^
960 tl_zeta_new(i,j)=tl_zeta(i,j,kbak)+ &
961 & fac*(tl_duon(i,j)-tl_duon(i+1,j)+ &
962 & tl_dvom(i,j)-tl_dvom(i,j+1))
963#ifdef MASKING
964!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
965!^
966 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
967# ifdef WET_DRY_NOT_YET
968!! zeta_new(i,j)=zeta_new(i,j)+ &
969!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
970# endif
971#endif
972!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
973!^
974 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
975
976 zwrk(i,j)=cff1*zeta_new(i,j)+ &
977 & cff2*zeta(i,j,kstp)+ &
978 & cff3*zeta(i,j,kbak)
979 tl_zwrk(i,j)=cff1*tl_zeta_new(i,j)+ &
980 & cff2*tl_zeta(i,j,kstp)+ &
981 & cff3*tl_zeta(i,j,kbak)
982#if defined VAR_RHO_2D && defined SOLVE3D
983 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
984 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
985 & tl_rhos(i,j)*zwrk(i,j)- &
986# ifdef TL_IOMS
987 & rhos(i,j)*zwrk(i,j)
988# endif
989 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
990 tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
991 & rzeta(i,j)*tl_zwrk(i,j)- &
992# ifdef TL_IOMS
993 & rzeta2(i,j)
994# endif
995 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
996 tl_rzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
997 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))- &
998# ifdef TL_IOMS
999 & rzetasa(i,j)
1000# endif
1001#else
1002 rzeta(i,j)=zwrk(i,j)
1003 tl_rzeta(i,j)=tl_zwrk(i,j)
1004 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1005 tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)- &
1006# ifdef TL_IOMS
1007 & rzeta2(i,j)
1008# endif
1009#endif
1010 END DO
1011 END DO
1012 ELSE !--> CORRECTOR STEP
1013 IF (first_2d_step) THEN
1014 cff =0.333333333333_r8 ! Modified RK2 weighting:
1015 cff1=0.333333333333_r8 ! here "zwrk" is time-
1016 cff2=0.333333333333_r8 ! centered at "n+1/2".
1017 cff3=0.0_r8
1018 ELSE
1019 cff =1.0_r8-epsil ! zwrk is always time-
1020 cff1=(0.5_r8-gamma)*epsil ! centered at n+1/2
1021 cff2=(0.5_r8+2.0_r8*gamma)*epsil ! during corrector sub-
1022 cff3=-gamma *epsil ! step.
1023 END IF
1024!
1025 DO j=jstrv-1,jend
1026 DO i=istru-1,iend
1027 fac=dtfast(ng)*pm(i,j)*pn(i,j)
1028!^ zeta_new(i,j)=zeta(i,j,kstp)+ &
1029!^ & fac*(DUon(i,j)-DUon(i+1,j)+ &
1030!^ & DVom(i,j)-DVom(i,j+1))
1031!^
1032 tl_zeta_new(i,j)=tl_zeta(i,j,kstp)+ &
1033 & fac*(tl_duon(i,j)-tl_duon(i+1,j)+ &
1034 & tl_dvom(i,j)-tl_dvom(i,j+1))
1035#ifdef MASKING
1036!^ zeta_new(i,j)=zeta_new(i,j)*rmask(i,j)
1037!^
1038 tl_zeta_new(i,j)=tl_zeta_new(i,j)*rmask(i,j)
1039# ifdef WET_DRY_NOT_YET
1040!! zeta_new(i,j)=zeta_new(i,j)+ &
1041!! & (Dcrit(ng)-h(i,j))*(1.0_r8-rmask(i,j))
1042# endif
1043#endif
1044!^ Dnew(i,j)=zeta_new(i,j)+h(i,j)
1045!^
1046 tl_dnew(i,j)=tl_zeta_new(i,j)+tl_h(i,j)
1047
1048 zwrk(i,j)=cff *zeta(i,j,krhs)+ &
1049 & cff1*zeta_new(i,j)+ &
1050 & cff2*zeta(i,j,kstp)+ &
1051 & cff3*zeta(i,j,kbak)
1052 tl_zwrk(i,j)=cff *tl_zeta(i,j,krhs)+ &
1053 & cff1*tl_zeta_new(i,j)+ &
1054 & cff2*tl_zeta(i,j,kstp)+ &
1055 & cff3*tl_zeta(i,j,kbak)
1056#if defined VAR_RHO_2D && defined SOLVE3D
1057 rzeta(i,j)=(1.0_r8+rhos(i,j))*zwrk(i,j)
1058 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
1059 & tl_rhos(i,j)*zwrk(i,j)- &
1060# ifdef TL_IOMS
1061 & rhos(i,j)*zwrk(i,j)
1062# endif
1063 rzeta2(i,j)=rzeta(i,j)*zwrk(i,j)
1064 tl_rzeta2(i,j)=tl_rzeta(i,j)*zwrk(i,j)+ &
1065 & rzeta(i,j)*tl_zwrk(i,j)- &
1066# ifdef TL_IOMS
1067 & rzeta2(i,j)
1068# endif
1069 rzetasa(i,j)=zwrk(i,j)*(rhos(i,j)-rhoa(i,j))
1070 tl_rzetasa(i,j)=tl_zwrk(i,j)*(rhos(i,j)-rhoa(i,j))+ &
1071 & zwrk(i,j)*(tl_rhos(i,j)-tl_rhoa(i,j))- &
1072# ifdef TL_IOMS
1073 & rzetasa(i,j)
1074# endif
1075#else
1076 rzeta(i,j)=zwrk(i,j)
1077 tl_rzeta(i,j)=tl_zwrk(i,j)
1078 rzeta2(i,j)=zwrk(i,j)*zwrk(i,j)
1079 tl_rzeta2(i,j)=2.0_r8*tl_zwrk(i,j)*zwrk(i,j)- &
1080# ifdef TL_IOMS
1081 & rzeta2(i,j)
1082# endif
1083#endif
1084 END DO
1085 END DO
1086 END IF
1087!
1088! Apply mass point sources (volume vertical influx), if any.
1089!
1090! Dsrc(is) = 2, flow across grid cell w-face (positive or negative)
1091!
1092 IF (lwsrc(ng)) THEN
1093 DO is=1,nsrc(ng)
1094 IF (int(sources(ng)%Dsrc(is)).eq.2) THEN
1095 i=sources(ng)%Isrc(is)
1096 j=sources(ng)%Jsrc(is)
1097 IF (((istrr.le.i).and.(i.le.iendr)).and. &
1098 & ((jstrr.le.j).and.(j.le.jendr))) THEN
1099!^ zeta_new(i,j)=zeta_new(i,j)+ &
1100!^ & SOURCES(ng)%Qbar(is)* &
1101!^ & pm(i,j)*pn(i,j)*dtfast(ng)
1102!^
1103! tl_zeta_new(i,j)=tl_zeta_new(i,j)+0.0_r8
1104 END IF
1105 END IF
1106 END DO
1107 END IF
1108!
1109! Apply boundary conditions to newly computed free-surface "zeta_new"
1110! and load into global state array. Notice that "zeta_new" is always
1111! centered at time step "m+1", while zeta(:,:,knew) should be centered
1112! either at "m+1/2" after predictor step and at "m+1" after corrector.
1113! Chosing it to be this way makes it possible avoid storing RHS for
1114! zeta, ubar, and vbar between predictor and corrector sub-steps.
1115!
1116! Here, we use the local "zetabc" since the private array "zeta_new"
1117! is passed as an argument to allow computing the lateral boundary
1118! conditions on the range IstrU-1:Iend and JstrV-1:Jend, so parallel
1119! tile exchanges are avoided.
1120!
1121!^ CALL zetabc_local (ng, tile, &
1122!^ & LBi, UBi, LBj, UBj, &
1123!^ & IminS, ImaxS, JminS, JmaxS, &
1124!^ & kstp, &
1125!^ & zeta, &
1126!^ & zeta_new)
1127!^
1128 CALL rp_zetabc_local (ng, tile, &
1129 & lbi, ubi, lbj, ubj, &
1130 & imins, imaxs, jmins, jmaxs, &
1131 & kstp, &
1132 & zeta, tl_zeta, &
1133 & zeta_new, tl_zeta_new)
1134!
1135 IF (predictor_2d_step) THEN
1136 IF (first_2d_step) THEN
1137 cff1=0.5_r8
1138 cff2=0.5_r8
1139 cff3=0.0_r8
1140 ELSE
1141 cff1=0.5_r8-gamma
1142 cff2=0.5_r8+2.0_r8*gamma
1143 cff3=-gamma
1144 END IF
1145 DO j=jstrr,jendr
1146 DO i=istrr,iendr
1147!^ zeta(i,j,knew)=cff1*zeta_new(i,j)+ &
1148!^ & cff2*zeta(i,j,kstp)+ &
1149!^ & cff3*zeta(i,j,kbak)
1150!^
1151 tl_zeta(i,j,knew)=cff1*tl_zeta_new(i,j)+ &
1152 & cff2*tl_zeta(i,j,kstp)+ &
1153 & cff3*tl_zeta(i,j,kbak)
1154 END DO
1155 END DO
1156 ELSE
1157 DO j=jstrr,jendr
1158 DO i=istrr,iendr
1159!^ zeta(i,j,knew)=zeta_new(i,j)
1160!^
1161 tl_zeta(i,j,knew)=tl_zeta_new(i,j)
1162 END DO
1163 END DO
1164 END IF
1165!
1166!=======================================================================
1167! Compute right-hand-side for the 2D momentum equations.
1168!=======================================================================
1169#ifdef SOLVE3D
1170!
1171! Notice that we are suppressing the computation of momentum advection,
1172! Coriolis, and lateral viscosity terms in 3D Applications because
1173! these terms are already included in the baroclinic-to-barotropic
1174! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely
1175! omitting them, but it is a choice between recomputing them at every
1176! barotropic step or keeping them "frozen" during the fast-time
1177! stepping.
1178# ifdef STEP2D_CORIOLIS
1179! However, in some coarse grid applications with larger baroclinic
1180! timestep (say, DT around 20 minutes or larger), adding the Coriolis
1181! term in the barotropic equations is useful since f*DT is no longer
1182! small.
1183# endif
1184#endif
1185!
1186!-----------------------------------------------------------------------
1187! Compute pressure-gradient terms.
1188!-----------------------------------------------------------------------
1189!
1190! Notice that "rubar" and "rvbar" are computed within the same to allow
1191! shared references to array elements (i,j), which increases the
1192! computational density by almost a factor of 1.5 resulting in overall
1193! more efficient code.
1194!
1195 cff1=0.5*g
1196 cff2=0.333333333333_r8
1197#if !defined SOLVE3D && defined ATM_PRESS
1198 fac=0.5_r8*100.0_r8/rho0
1199#endif
1200 DO j=jstr,jend
1201 DO i=istr,iend
1202 IF (i.ge.istru) THEN
1203!^ rubar(i,j)=cff1*on_u(i,j)* &
1204!^ & ((h(i-1,j)+ &
1205!^ & h(i ,j))* &
1206!^ & (rzeta(i-1,j)- &
1207!^ & rzeta(i ,j))+ &
1208#if defined VAR_RHO_2D && defined SOLVE3D
1209!^ & (h(i-1,j)- &
1210!^ & h(i ,j))* &
1211!^ & (rzetaSA(i-1,j)+ &
1212!^ & rzetaSA(i ,j)+ &
1213!^ & cff2*(rhoA(i-1,j)- &
1214!^ & rhoA(i ,j))* &
1215!^ & (zwrk(i-1,j)- &
1216!^ & zwrk(i ,j)))+ &
1217#endif
1218!^ & (rzeta2(i-1,j)- &
1219!^ & rzeta2(i ,j)))
1220!^
1221 tl_rubar(i,j)=cff1*on_u(i,j)* &
1222 & ((h(i-1,j)+ &
1223 & h(i ,j))* &
1224 & (tl_rzeta(i-1,j)- &
1225 & tl_rzeta(i ,j))+ &
1226#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1227 & (tl_h(i-1,j)+ &
1228 & tl_h(i ,j))* &
1229 & (rzeta(i-1,j)- &
1230 & rzeta(i ,j))- &
1231# ifdef TL_IOMS
1232 & (h(i-1,j)+ &
1233 & h(i ,j))* &
1234 & (rzeta(i-1,j)- &
1235 & rzeta(i ,j))+ &
1236# endif
1237#endif
1238#if defined VAR_RHO_2D && defined SOLVE3D
1239# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1240 & (tl_h(i-1,j)- &
1241 & tl_h(i ,j))* &
1242 & (rzetasa(i-1,j)+ &
1243 & rzetasa(i ,j)+ &
1244 & cff2*(rhoa(i-1,j)- &
1245 & rhoa(i ,j))* &
1246 & (zwrk(i-1,j)- &
1247 & zwrk(i ,j)))+ &
1248# endif
1249 & (h(i-1,j)- &
1250 & h(i ,j))* &
1251 & (tl_rzetasa(i-1,j)+ &
1252 & tl_rzetasa(i ,j)+ &
1253 & cff2*((tl_rhoa(i-1,j)- &
1254 & tl_rhoa(i ,j))* &
1255 & (zwrk(i-1,j)- &
1256 & zwrk(i ,j))+ &
1257 & (rhoa(i-1,j)- &
1258 & rhoa(i ,j))* &
1259 & (tl_zwrk(i-1,j)- &
1260 & tl_zwrk(i ,j))))- &
1261# ifdef TL_IOMS
1262# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1263 & (h(i-1,j)- &
1264 & h(i ,j))* &
1265 & (rzetasa(i-1,j)+ &
1266 & rzetasa(i ,j))- &
1267 & 2.0_r8* &
1268# endif
1269 & (h(i-1,j)- &
1270 & h(i ,j))* &
1271 & (cff2*(rhoa(i-1,j)- &
1272 & rhoa(i ,j))* &
1273 & (zwrk(i-1,j)- &
1274 & zwrk(i ,j)))+ &
1275# endif
1276#endif
1277 & (tl_rzeta2(i-1,j)- &
1278 & tl_rzeta2(i ,j)))
1279#if defined ATM_PRESS && !defined SOLVE3D
1280!^ rubar(i,j)=rubar(i,j)- &
1281!^ & fac*on_u(i,j)* &
1282!^ & (h(i-1,j)+h(i,j)+ &
1283!^ & rzeta(i-1,j)+rzeta(i,j))* &
1284!^ & (Pair(i,j)-Pair(i-1,j))
1285!^
1286 tl_rubar(i,j)=tl_rubar(i,j)- &
1287 & fac*on_u(i,j)* &
1288 & (tl_h(i-1,j)+tl_h(i,j)+ &
1289 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1290 & (pair(i,j)-pair(i-1,j))
1291#endif
1292#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1293!^ rubar(i,j)=rubar(i,j)- &
1294!^ & cff1*on_u(i,j)* &
1295!^ & (h(i-1,j)+h(i,j)+ &
1296!^ & rzeta(i-1,j)+rzeta(i,j))* &
1297!^ & (eq_tide(i,j)-eq_tide(i-1,j))
1298!^
1299 tl_rubar(i,j)=tl_rubar(i,j)- &
1300 & cff1*on_u(i,j)* &
1301 & ((tl_h(i-1,j)+tl_h(i,j)+ &
1302 & tl_rzeta(i-1,j)+tl_rzeta(i,j))* &
1303 & (eq_tide(i,j)-eq_tide(i-1,j))+ &
1304 & (h(i-1,j)+h(i,j)+ &
1305 & rzeta(i-1,j)+rzeta(i,j))* &
1306 & (tl_eq_tide(i,j)-tl_eq_tide(i-1,j)))- &
1307# ifdef TL_IOMS
1308 & (h(i-1,j)+h(i,j)+ &
1309 & rzeta(i-1,j)+rzeta(i,j))* &
1310 & (eq_tide(i,j)-eq_tide(i-1,j)))
1311# endif
1312#endif
1313#ifdef DIAGNOSTICS_UV
1314!! DiaU2rhs(i,j,M2pgrd)=rubar(i,j)
1315#endif
1316 END IF
1317!
1318 IF (j.ge.jstrv) THEN
1319!^ rvbar(i,j)=cff1*om_v(i,j)* &
1320!^ & ((h(i,j-1)+ &
1321!^ & h(i,j ))* &
1322!^ & (rzeta(i,j-1)- &
1323!^ & rzeta(i,j ))+ &
1324#if defined VAR_RHO_2D && defined SOLVE3D
1325!^ & (h(i,j-1)- &
1326!^ & h(i,j ))* &
1327!^ & (rzetaSA(i,j-1)+ &
1328!^ & rzetaSA(i,j )+ &
1329!^ & cff2*(rhoA(i,j-1)- &
1330!^ & rhoA(i,j ))* &
1331!^ & (zwrk(i,j-1)- &
1332!^ & zwrk(i,j )))+ &
1333#endif
1334!^ & (rzeta2(i,j-1)- &
1335!^ & rzeta2(i,j )))
1336!^
1337 tl_rvbar(i,j)=cff1*om_v(i,j)* &
1338 & ((h(i,j-1)+ &
1339 & h(i,j ))* &
1340 & (tl_rzeta(i,j-1)- &
1341 & tl_rzeta(i,j ))+ &
1342#if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1343 & (tl_h(i,j-1)+ &
1344 & tl_h(i,j ))* &
1345 & (rzeta(i,j-1)- &
1346 & rzeta(i,j ))- &
1347# ifdef TL_IOMS
1348 & (h(i,j-1)+ &
1349 & h(i,j ))* &
1350 & (rzeta(i,j-1)- &
1351 & rzeta(i,j ))+ &
1352# endif
1353#endif
1354#if defined VAR_RHO_2D && defined SOLVE3D
1355# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1356 & (tl_h(i,j-1)- &
1357 & tl_h(i,j ))* &
1358 & (rzetasa(i,j-1)+ &
1359 & rzetasa(i,j )+ &
1360 & cff2*(rhoa(i,j-1)- &
1361 & rhoa(i,j ))* &
1362 & (zwrk(i,j-1)- &
1363 & zwrk(i,j )))+ &
1364# endif
1365 & (h(i,j-1)- &
1366 & h(i,j ))* &
1367 & (tl_rzetasa(i,j-1)+ &
1368 & tl_rzetasa(i,j )+ &
1369 & cff2*((tl_rhoa(i,j-1)- &
1370 & tl_rhoa(i,j ))* &
1371 & (zwrk(i,j-1)- &
1372 & zwrk(i,j ))+ &
1373 & (rhoa(i,j-1)- &
1374 & rhoa(i,j ))* &
1375 & (tl_zwrk(i,j-1)- &
1376 & tl_zwrk(i,j ))))- &
1377# ifdef TL_IOMS
1378# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
1379 & (h(i,j-1)- &
1380 & h(i,j ))* &
1381 & (rzetasa(i,j-1)+ &
1382 & rzetasa(i,j ))- &
1383 & 2.0_r8* &
1384# endif
1385 & (h(i,j-1)- &
1386 & h(i,j ))* &
1387 & (cff2*(rhoa(i,j-1)- &
1388 & rhoa(i,j ))* &
1389 & (zwrk(i,j-1)- &
1390 & zwrk(i,j )))+ &
1391# endif
1392#endif
1393 & (tl_rzeta2(i,j-1)- &
1394 & tl_rzeta2(i,j )))
1395#if defined ATM_PRESS && !defined SOLVE3D
1396!^ rvbar(i,j)=rvbar(i,j)- &
1397!^ & fac*om_v(i,j)* &
1398!^ & (h(i,j-1)+h(i,j)+ &
1399!^ & rzeta(i,j-1)+rzeta(i,j))* &
1400!^ & (Pair(i,j)-Pair(i,j-1))
1401!^
1402 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1403 & fac*om_v(i,j)* &
1404 & (tl_h(i,j-1)+tl_h(i,j)+ &
1405 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1406 & (pair(i,j)-pair(i,j-1))
1407#endif
1408#if defined TIDE_GENERATING_FORCES && !defined SOLVE3D
1409!^ rvbar(i,j)=rvbar(i,j)- &
1410!^ & cff1*om_v(i,j)* &
1411!^ & (h(i,j-1)+h(i,j)+ &
1412!^ & rzeta(i,j-1)+rzeta(i,j))* &
1413!^ & (eq_tide(i,j)-eq_tide(i,j-1))
1414!^
1415 tl_rvbar(i,j)=tl_rvbar(i,j)- &
1416 & cff1*om_v(i,j)* &
1417 & ((tl_h(i,j-1)+tl_h(i,j)+ &
1418 & tl_rzeta(i,j-1)+tl_rzeta(i,j))* &
1419 & (eq_tide(i,j)-eq_tide(i,j-1))+ &
1420 & (h(i,j-1)+h(i,j)+ &
1421 & rzeta(i,j-1)+rzeta(i,j))* &
1422 & (tl_eq_tide(i,j)-tl_eq_tide(i,j-1)))- &
1423# ifdef TL_IOMS
1424 & (h(i,j-1)+h(i,j)+ &
1425 & rzeta(i,j-1)+rzeta(i,j))* &
1426 & (eq_tide(i,j)-eq_tide(i,j-1)))
1427# endif
1428#endif
1429#ifdef DIAGNOSTICS_UV
1430!! DiaV2rhs(i,j,M2pgrd)=rvbar(i,j)
1431#endif
1432 END IF
1433 END DO
1434 END DO
1435
1436#if defined UV_ADV && !defined SOLVE3D
1437!
1438!-----------------------------------------------------------------------
1439! Add in horizontal advection of momentum.
1440!-----------------------------------------------------------------------
1441
1442# ifdef UV_C2ADVECTION
1443!
1444! Second-order, centered differences advection fluxes.
1445!
1446 DO j=jstr,jend
1447 DO i=istru-1,iend
1448 ufx(i,j)=0.25_r8* &
1449 & (duon(i,j)+duon(i+1,j))* &
1450 & (ubar(i ,j,krhs)+ &
1451# ifdef WEC_MELLOR
1452 & ubar_stokes(i ,j)+ &
1453 & ubar_stokes(i+1,j)+ &
1454# endif
1455 & ubar(i+1,j,krhs))
1456!
1457 tl_ufx(i,j)=0.25_r8* &
1458 & ((tl_duon(i,j)+tl_duon(i+1,j))* &
1459 & (ubar(i ,j,krhs)+ &
1460# ifdef WEC_MELLOR
1461 & ubar_stokes(i ,j)+ &
1462 & ubar_stokes(i+1,j)+ &
1463# endif
1464 & ubar(i+1,j,krhs))+ &
1465 & (duon(i,j)+duon(i+1,j))* &
1466 & (tl_ubar(i ,j,krhs)+ &
1467# ifdef WEC_MELLOR
1468 & tl_ubar_stokes(i ,j)+ &
1469 & tl_ubar_stokes(i+1,j)+ &
1470# endif
1471 & tl_ubar(i+1,j,krhs)))- &
1472# ifdef TL_IOMS
1473 & ufx(i,j)
1474# endif
1475 END DO
1476 END DO
1477!
1478 DO j=jstr,jend+1
1479 DO i=istru,iend
1480 ufe(i,j)=0.25_r8* &
1481 & (dvom(i,j)+dvom(i-1,j))* &
1482 & (ubar(i,j ,krhs)+ &
1483# ifdef WEC_MELLOR
1484 & ubar_stokes(i,j )+ &
1485 & ubar_stokes(i,j-1)+ &
1486# endif
1487 & ubar(i,j-1,krhs))
1488!
1489 tl_ufe(i,j)=0.25_r8* &
1490 & ((tl_dvom(i,j)+tl_dvom(i-1,j))* &
1491 & (ubar(i,j ,krhs)+ &
1492# ifdef WEC_MELLOR
1493 & ubar_stokes(i,j )+ &
1494 & ubar_stokes(i,j-1)+ &
1495# endif
1496 & ubar(i,j-1,krhs))+ &
1497 & (dvom(i,j)+dvom(i-1,j))* &
1498 & (tl_ubar(i,j ,krhs)+ &
1499# ifdef WEC_MELLOR
1500 & tl_ubar_stokes(i,j )+ &
1501 & tl_ubar_stokes(i,j-1)+ &
1502# endif
1503 & tl_ubar(i,j-1,krhs)))- &
1504# ifdef TL_IOMS
1505 & ufe(i,j)
1506# endif
1507 END DO
1508 END DO
1509!
1510 DO j=jstrv,jend
1511 DO i=istr,iend+1
1512 vfx(i,j)=0.25_r8* &
1513 & (duon(i,j)+duon(i,j-1))* &
1514 & (vbar(i ,j,krhs)+ &
1515# ifdef WEC_MELLOR
1516 & vbar_stokes(i ,j)+ &
1517 & vbar_stokes(i-1,j)+ &
1518# endif
1519 & vbar(i-1,j,krhs))
1520!
1521 tl_vfx(i,j)=0.25_r8* &
1522 & ((tl_duon(i,j)+tl_duon(i,j-1))* &
1523 & (vbar(i ,j,krhs)+ &
1524# ifdef WEC_MELLOR
1525 & vbar_stokes(i ,j)+ &
1526 & vbar_stokes(i-1,j)+ &
1527# endif
1528 & vbar(i-1,j,krhs))+ &
1529 & (duon(i,j)+duon(i,j-1))* &
1530 & (tl_vbar(i ,j,krhs)+ &
1531# ifdef WEC_MELLOR
1532 & tl_vbar_stokes(i ,j)+ &
1533 & tl_vbar_stokes(i-1,j)+ &
1534# endif
1535 & tl_vbar(i-1,j,krhs)))- &
1536# ifdef TL_IOMS
1537 & vfx(i,j)
1538# endif
1539 END DO
1540 END DO
1541!
1542 DO j=jstrv-1,jend
1543 DO i=istr,iend
1544 vfe(i,j)=0.25_r8* &
1545 & (dvom(i,j)+dvom(i,j+1))* &
1546 & (vbar(i,j ,krhs)+ &
1547# ifdef WEC_MELLOR
1548 & vbar_stokes(i,j )+ &
1549 & vbar_stokes(i,j+1)+ &
1550# endif
1551 & vbar(i,j+1,krhs))
1552!
1553 tl_vfe(i,j)=0.25_r8* &
1554 & ((tl_dvom(i,j)+tl_dvom(i,j+1))* &
1555 & (vbar(i,j ,krhs)+ &
1556# ifdef WEC_MELLOR
1557 & vbar_stokes(i,j )+ &
1558 & vbar_stokes(i,j+1)+ &
1559# endif
1560 & vbar(i,j+1,krhs))+ &
1561 & (dvom(i,j)+dvom(i,j+1))* &
1562 & (tl_vbar(i,j ,krhs)+ &
1563# ifdef WEC_MELLOR
1564 & tl_vbar_stokes(i,j )+ &
1565 & tl_vbar_stokes(i,j+1)+ &
1566# endif
1567 & tl_vbar(i,j+1,krhs)))- &
1568# ifdef TL_IOMS
1569 & vfe(i,j)
1570# endif
1571 END DO
1572 END DO
1573
1574# elif defined UV_C4ADVECTION
1575!
1576! Fourth-order, centered differences u-momentum advection fluxes.
1577!
1578 DO j=jstr,jend
1579 DO i=istrum1,iendp1
1580 grad(i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1581# ifdef WEC_MELLOR
1582 & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ &
1583 & ubar_stokes(i+1,j)+ &
1584# endif
1585 & ubar(i+1,j,krhs)
1586 tl_grad(i,j)=tl_ubar(i-1,j,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1587# ifdef WEC_MELLOR
1588 & tl_ubar_stokes(i-1,j)-2.0_r8*tl_ubar_stokes(i,j)+&
1589 & tl_ubar_stokes(i+1,j)+ &
1590# endif
1591 & tl_ubar(i+1,j,krhs)
1592 dgrad(i,j)=duon(i-1,j)-2.0_r8*duon(i,j)+duon(i+1,j)
1593 tl_dgrad(i,j)=tl_duon(i-1,j)-2.0_r8*tl_duon(i,j)+ &
1594 & tl_duon(i+1,j)
1595 END DO
1596 END DO
1597 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1598 IF (domain(ng)%Western_Edge(tile)) THEN
1599 DO j=jstr,jend
1600 grad(istr,j)=grad(istr+1,j)
1601 tl_grad(istr,j)=tl_grad(istr+1,j)
1602 dgrad(istr,j)=dgrad(istr+1,j)
1603 tl_dgrad(istr,j)=tl_dgrad(istr+1,j)
1604 END DO
1605 END IF
1606 END IF
1607 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1608 IF (domain(ng)%Eastern_Edge(tile)) THEN
1609 DO j=jstr,jend
1610 grad(iend+1,j)=grad(iend,j)
1611 tl_grad(iend+1,j)=tl_grad(iend,j)
1612 dgrad(iend+1,j)=dgrad(iend,j)
1613 tl_dgrad(iend+1,j)=tl_dgrad(iend,j)
1614 END DO
1615 END IF
1616 END IF
1617! d/dx(Duu/n)
1618 cff=1.0_r8/6.0_r8
1619 DO j=jstr,jend
1620 DO i=istru-1,iend
1621 ufx(i,j)=0.25_r8*(ubar(i ,j,krhs)+ &
1622# ifdef WEC_MELLOR
1623 & ubar_stokes(i ,j)+ &
1624 & ubar_stokes(i+1,j)+ &
1625# endif
1626 & ubar(i+1,j,krhs)- &
1627 & cff*(grad(i,j)+grad(i+1,j)))* &
1628 & (duon(i,j)+duon(i+1,j)- &
1629 & cff*(dgrad(i,j)+dgrad(i+1,j)))
1630!
1631 tl_ufx(i,j)=0.25_r8* &
1632 & ((ubar(i ,j,krhs)+ &
1633# ifdef WEC_MELLOR
1634 & ubar_stokes(i ,j)+ &
1635 & ubar_stokes(i+1,j)+ &
1636# endif
1637 & ubar(i+1,j,krhs)- &
1638 & cff*(grad(i,j)+grad(i+1,j)))* &
1639 & (tl_duon(i,j)+tl_duon(i+1,j)- &
1640 & cff*(tl_dgrad(i,j)+tl_dgrad(i+1,j)))+ &
1641 & (tl_ubar(i ,j,krhs)+ &
1642# ifdef WEC_MELLOR
1643 & tl_ubar_stokes(i ,j)+ &
1644 & tl_ubar_stokes(i+1,j)+ &
1645# endif
1646 & tl_ubar(i+1,j,krhs)- &
1647 & cff*(tl_grad(i,j)+tl_grad(i+1,j)))* &
1648 & (duon(i,j)+duon(i+1,j)- &
1649 & cff*(dgrad(i,j)+dgrad(i+1,j))))- &
1650# ifdef TL_IOMS
1651 & ufx(i,j)
1652# endif
1653 END DO
1654 END DO
1655!
1656 DO j=jstrm1,jendp1
1657 DO i=istru,iend
1658 grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ &
1659# ifdef WEC_MELLOR
1660 & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ &
1661 & ubar_stokes(i,j+1)+ &
1662# endif
1663 & ubar(i,j+1,krhs)
1664 tl_grad(i,j)=tl_ubar(i,j-1,krhs)-2.0_r8*tl_ubar(i,j,krhs)+ &
1665# ifdef WEC_MELLOR
1666 & tl_ubar_stokes(i,j-1)-2.0_r8*tl_ubar_stokes(i,j)+&
1667 & tl_ubar_stokes(i,j+1)+ &
1668# endif
1669 & tl_ubar(i,j+1,krhs)
1670 END DO
1671 END DO
1672!
1673 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1674 IF (domain(ng)%Southern_Edge(tile)) THEN
1675 DO i=istru,iend
1676 grad(i,jstr-1)=grad(i,jstr)
1677 tl_grad(i,jstr-1)=tl_grad(i,jstr)
1678 END DO
1679 END IF
1680 END IF
1681 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1682 IF (domain(ng)%Northern_Edge(tile)) THEN
1683 DO i=istru,iend
1684 grad(i,jend+1)=grad(i,jend)
1685 tl_grad(i,jend+1)=tl_grad(i,jend)
1686 END DO
1687 END IF
1688 END IF
1689 DO j=jstr,jend+1
1690 DO i=istru-1,iend
1691 dgrad(i,j)=dvom(i-1,j)-2.0_r8*dvom(i,j)+dvom(i+1,j)
1692 tl_dgrad(i,j)=tl_dvom(i-1,j)-2.0_r8*tl_dvom(i,j)+ &
1693 & tl_dvom(i+1,j)
1694 END DO
1695 END DO
1696! d/dy(Duv/m)
1697 cff=1.0_r8/6.0_r8
1698 DO j=jstr,jend+1
1699 DO i=istru,iend
1700 ufe(i,j)=0.25_r8*(ubar(i,j ,krhs)+ &
1701# ifdef WEC_MELLOR
1702 & ubar_stokes(i,j )+ &
1703 & ubar_stokes(i,j-1)+ &
1704# endif
1705 & ubar(i,j-1,krhs)- &
1706 & cff*(grad(i,j)+grad(i,j-1)))* &
1707 & (dvom(i,j)+dvom(i-1,j)- &
1708 & cff*(dgrad(i,j)+dgrad(i-1,j)))
1709!
1710 tl_ufe(i,j)=0.25_r8* &
1711 & ((tl_ubar(i,j ,krhs)+ &
1712# ifdef WEC_MELLOR
1713 & tl_ubar_stokes(i,j )+ &
1714 & tl_ubar_stokes(i,j-1)+ &
1715# endif
1716 & tl_ubar(i,j-1,krhs)- &
1717 & cff*(tl_grad(i,j)+tl_grad(i,j-1)))* &
1718 & (dvom(i,j)+dvom(i-1,j)- &
1719 & cff*(dgrad(i,j)+dgrad(i-1,j)))+ &
1720 & (ubar(i,j ,krhs)+ &
1721# ifdef WEC_MELLOR
1722 & ubar_stokes(i,j )+ &
1723 & ubar_stokes(i,j-1)+ &
1724# endif
1725 & ubar(i,j-1,krhs)- &
1726 & cff*(grad(i,j)+grad(i,j-1)))* &
1727 & (tl_dvom(i,j)+tl_dvom(i-1,j)- &
1728 & cff*(tl_dgrad(i,j)+tl_dgrad(i-1,j))))- &
1729# ifdef TL_IOMS
1730 & ufe(i,j)
1731# endif
1732 END DO
1733 END DO
1734!
1735! Fourth-order, centered differences v-momentum advection fluxes.
1736!
1737 DO j=jstrv,jend
1738 DO i=istrm1,iendp1
1739 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1740# ifdef WEC_MELLOR
1741 & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ &
1742 & vbar_stokes(i+1,j)+ &
1743# endif
1744 & vbar(i+1,j,krhs)
1745 tl_grad(i,j)=tl_vbar(i-1,j,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1746# ifdef WEC_MELLOR
1747 & tl_vbar_stokes(i-1,j)-2.0_r8*tl_vbar_stokes(i,j)+&
1748 & tl_vbar_stokes(i+1,j)+ &
1749# endif
1750 & tl_vbar(i+1,j,krhs)
1751 END DO
1752 END DO
1753!
1754 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
1755 IF (domain(ng)%Western_Edge(tile)) THEN
1756 DO j=jstrv,jend
1757 grad(istr-1,j)=grad(istr,j)
1758 tl_grad(istr-1,j)=tl_grad(istr,j)
1759 END DO
1760 END IF
1761 END IF
1762 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
1763 IF (domain(ng)%Eastern_Edge(tile)) THEN
1764 DO j=jstrv,jend
1765 grad(iend+1,j)=grad(iend,j)
1766 tl_grad(iend+1,j)=tl_grad(iend,j)
1767 END DO
1768 END IF
1769 END IF
1770 DO j=jstrv-1,jend
1771 DO i=istr,iend+1
1772 dgrad(i,j)=duon(i,j-1)-2.0_r8*duon(i,j)+duon(i,j+1)
1773 tl_dgrad(i,j)=tl_duon(i,j-1)-2.0_r8*tl_duon(i,j)+ &
1774 & tl_duon(i,j+1)
1775 END DO
1776 END DO
1777! d/dx(Duv/n)
1778 cff=1.0_r8/6.0_r8
1779 DO j=jstrv,jend
1780 DO i=istr,iend+1
1781 vfx(i,j)=0.25_r8*(vbar(i ,j,krhs)+ &
1782# ifdef WEC_MELLOR
1783 & vbar_stokes(i ,j)+ &
1784 & vbar_stokes(i-1,j)+ &
1785# endif
1786 & vbar(i-1,j,krhs)- &
1787 & cff*(grad(i,j)+grad(i-1,j)))* &
1788 & (duon(i,j)+duon(i,j-1)- &
1789 & cff*(dgrad(i,j)+dgrad(i,j-1)))
1790!
1791 tl_vfx(i,j)=0.25_r8* &
1792 & ((tl_vbar(i ,j,krhs)+ &
1793# ifdef WEC_MELLOR
1794 & tl_vbar_stokes(i ,j)+ &
1795 & tl_vbar_stokes(i-1,j)+ &
1796# endif
1797 & tl_vbar(i-1,j,krhs)- &
1798 & cff*(tl_grad(i,j)+tl_grad(i-1,j)))* &
1799 & (duon(i,j)+duon(i,j-1)- &
1800 & cff*(dgrad(i,j)+dgrad(i,j-1)))+ &
1801 & (vbar(i ,j,krhs)+ &
1802# ifdef WEC_MELLOR
1803 & vbar_stokes(i ,j)+ &
1804 & vbar_stokes(i-1,j)+ &
1805# endif
1806 & vbar(i-1,j,krhs)- &
1807 & cff*(grad(i,j)+grad(i-1,j)))* &
1808 & (tl_duon(i,j)+tl_duon(i,j-1)- &
1809 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j-1))))- &
1810# ifdef TL_IOMS
1811 & vfx(i,j)
1812# endif
1813 END DO
1814 END DO
1815!
1816 DO j=jstrvm1,jendp1
1817 DO i=istr,iend
1818 grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ &
1819# ifdef WEC_MELLOR
1820 & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ &
1821 & vbar_stokes(i,j+1)+ &
1822# endif
1823 & vbar(i,j+1,krhs)
1824 tl_grad(i,j)=tl_vbar(i,j-1,krhs)-2.0_r8*tl_vbar(i,j,krhs)+ &
1825# ifdef WEC_MELLOR
1826 & tl_vbar_stokes(i,j-1)-2.0_r8*tl_vbar_stokes(i,j)+&
1827 & tl_vbar_stokes(i,j+1)+ &
1828# endif
1829 & tl_vbar(i,j+1,krhs)
1830 dgrad(i,j)=dvom(i,j-1)-2.0_r8*dvom(i,j)+dvom(i,j+1)
1831 tl_dgrad(i,j)=tl_dvom(i,j-1)-2.0_r8*tl_dvom(i,j)+ &
1832 & tl_dvom(i,j+1)
1833 END DO
1834 END DO
1835 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
1836 IF (domain(ng)%Southern_Edge(tile)) THEN
1837 DO i=istr,iend
1838 grad(i,jstr)=grad(i,jstr+1)
1839 tl_grad(i,jstr)=tl_grad(i,jstr+1)
1840 dgrad(i,jstr)=dgrad(i,jstr+1)
1841 tl_dgrad(i,jstr)=tl_dgrad(i,jstr+1)
1842 END DO
1843 END IF
1844 END IF
1845 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
1846 IF (domain(ng)%Northern_Edge(tile)) THEN
1847 DO i=istr,iend
1848 grad(i,jend+1)=grad(i,jend)
1849 tl_grad(i,jend+1)=tl_grad(i,jend)
1850 dgrad(i,jend+1)=dgrad(i,jend)
1851 tl_dgrad(i,jend+1)=tl_dgrad(i,jend)
1852 END DO
1853 END IF
1854 END IF
1855! d/dy(Dvv/m)
1856 cff=1.0_r8/6.0_r8
1857 DO j=jstrv-1,jend
1858 DO i=istr,iend
1859 vfe(i,j)=0.25_r8*(vbar(i,j ,krhs)+ &
1860# ifdef WEC_MELLOR
1861 & vbar_stokes(i,j )+ &
1862 & vbar_stokes(i,j+1)+ &
1863# endif
1864 & vbar(i,j+1,krhs)- &
1865 & cff*(grad(i,j)+grad(i,j+1)))* &
1866 & (dvom(i,j)+dvom(i,j+1)- &
1867 & cff*(dgrad(i,j)+dgrad(i,j+1)))
1868!
1869 tl_vfe(i,j)=0.25_r8* &
1870 & ((tl_vbar(i,j ,krhs)+ &
1871# ifdef WEC_MELLOR
1872 & tl_vbar_stokes(i,j )+ &
1873 & tl_vbar_stokes(i,j+1)+ &
1874# endif
1875 & tl_vbar(i,j+1,krhs)- &
1876 & cff*(tl_grad(i,j)+tl_grad(i,j+1)))* &
1877 & (dvom(i,j)+dvom(i,j+1)- &
1878 & cff*(dgrad(i,j)+dgrad(i,j+1)))+ &
1879 & (vbar(i,j ,krhs)+ &
1880# ifdef WEC_MELLOR
1881 & vbar_stokes(i,j )+ &
1882 & vbar_stokes(i,j+1)+ &
1883# endif
1884 & vbar(i,j+1,krhs)- &
1885 & cff*(grad(i,j)+grad(i,j+1)))* &
1886 & (tl_dvom(i,j)+tl_dvom(i,j+1)- &
1887 & cff*(tl_dgrad(i,j)+tl_dgrad(i,j+1))))- &
1888# ifdef TL_IOMS
1889 & vfe(i,j)
1890# endif
1891 END DO
1892 END DO
1893# endif
1894!
1895! Add advection to RHS terms.
1896!
1897 DO j=jstr,jend
1898 DO i=istr,iend
1899 IF (i.ge.istru) THEN
1900!^ cff1=UFx(i,j)-UFx(i-1,j)
1901!^
1902 tl_cff1=tl_ufx(i,j)-tl_ufx(i-1,j)
1903!^ cff2=UFe(i,j+1)-UFe(i,j)
1904!^
1905 tl_cff2=tl_ufe(i,j+1)-tl_ufe(i,j)
1906!^ fac=cff1+cff2
1907!^
1908 tl_fac=tl_cff1+tl_cff2
1909!^ rubar(i,j)=rubar(i,j)-fac
1910!^
1911 tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
1912# if defined DIAGNOSTICS_UV
1913!! DiaU2rhs(i,j,M2xadv)=-cff1
1914!! DiaU2rhs(i,j,M2yadv)=-cff2
1915!! DiaU2rhs(i,j,M2hadv)=-fac
1916# endif
1917 END IF
1918!
1919 IF (j.ge.jstrv) THEN
1920!^ cff1=VFx(i+1,j)-VFx(i,j)
1921!^
1922 tl_cff1=tl_vfx(i+1,j)-tl_vfx(i,j)
1923!^ cff2=VFe(i,j)-VFe(i,j-1)
1924!^
1925 tl_cff2=tl_vfe(i,j)-tl_vfe(i,j-1)
1926!^ fac=cff1+cff2
1927!^
1928 tl_fac=tl_cff1+tl_cff2
1929!^ rvbar(i,j)=rvbar(i,j)-fac
1930!^
1931 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
1932# if defined DIAGNOSTICS_UV
1933!! DiaV2rhs(i,j,M2xadv)=-cff1
1934!! DiaV2rhs(i,j,M2yadv)=-cff2
1935!! DiaV2rhs(i,j,M2hadv)=-fac
1936# endif
1937 END IF
1938 END DO
1939 END DO
1940#endif
1941
1942#if (defined UV_COR & !defined SOLVE3D) || defined STEP2D_CORIOLIS
1943!
1944!-----------------------------------------------------------------------
1945! Add in Coriolis term.
1946!-----------------------------------------------------------------------
1947!
1948 DO j=jstrv-1,jend
1949 DO i=istru-1,iend
1950 cff=0.5_r8*drhs(i,j)*fomn(i,j)
1951 tl_cff=0.5_r8*tl_drhs(i,j)*fomn(i,j)
1952 ufx(i,j)=cff*(vbar(i,j ,krhs)+ &
1953# ifdef WEC_MELLOR
1954 & vbar_stokes(i,j )+ &
1955 & vbar_stokes(i,j+1)+ &
1956# endif
1957 & vbar(i,j+1,krhs))
1958!
1959 tl_ufx(i,j)=tl_cff*(vbar(i,j ,krhs)+ &
1960# ifdef WEC_MELLOR
1961 & vbar_stokes(i,j )+ &
1962 & vbar_stokes(i,j+1)+ &
1963# endif
1964 & vbar(i,j+1,krhs))+ &
1965 & cff*(tl_vbar(i,j ,krhs)+ &
1966# ifdef WEC_MELLOR
1967 & tl_vbar_stokes(i,j )+ &
1968 & tl_vbar_stokes(i,j+1)+ &
1969# endif
1970 & tl_vbar(i,j+1,krhs))- &
1971# ifdef TL_IOMS
1972 & ufx(i,j)
1973# endif
1974!
1975 vfe(i,j)=cff*(ubar(i ,j,krhs)+ &
1976# ifdef WEC_MELLOR
1977 & ubar_stokes(i ,j)+ &
1978 & ubar_stokes(i+1,j)+ &
1979# endif
1980 & ubar(i+1,j,krhs))
1981!
1982 tl_vfe(i,j)=tl_cff*(ubar(i ,j,krhs)+ &
1983# ifdef WEC_MELLOR
1984 & ubar_stokes(i ,j)+ &
1985 & ubar_stokes(i+1,j)+ &
1986# endif
1987 & ubar(i+1,j,krhs))+ &
1988 & cff*(tl_ubar(i ,j,krhs)+ &
1989# ifdef WEC_MELLOR
1990 & tl_ubar_stokes(i ,j)+ &
1991 & tl_ubar_stokes(i+1,j)+ &
1992# endif
1993 & tl_ubar(i+1,j,krhs))- &
1994# ifdef TL_IOMS
1995 & vfe(i,j)
1996# endif
1997 END DO
1998 END DO
1999!
2000 DO j=jstr,jend
2001 DO i=istr,iend
2002 IF (i.ge.istru) THEN
2003!^ fac1=0.5_r8*(UFx(i,j)+UFx(i-1,j))
2004!^
2005 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
2006!^ rubar(i,j)=rubar(i,j)+fac1
2007!^
2008 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac1
2009# if defined DIAGNOSTICS_UV
2010!! DiaU2rhs(i,j,M2fcor)=fac1
2011# endif
2012 END IF
2013!
2014 IF (j.ge.jstrv) THEN
2015!^ fac2=0.5_r8*(VFe(i,j)+VFe(i,j-1))
2016!^
2017 tl_fac2=0.5_r8*(tl_vfe(i,j)+tl_vfe(i,j-1))
2018!^ rvbar(i,j)=rvbar(i,j)-fac2
2019!^
2020 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac2
2021# if defined DIAGNOSTICS_UV
2022!! DiaV2rhs(i,j,M2fcor)=-fac2
2023# endif
2024 END IF
2025 END DO
2026 END DO
2027#endif
2028
2029#if (defined CURVGRID && defined UV_ADV) && !defined SOLVE3D
2030!
2031!-----------------------------------------------------------------------
2032! Add in curvilinear transformation terms.
2033!-----------------------------------------------------------------------
2034!
2035 DO j=jstrv-1,jend
2036 DO i=istru-1,iend
2037 cff1=0.5_r8*(vbar(i,j ,krhs)+ &
2038# ifdef WEC_MELLOR
2039 & vbar_stokes(i,j )+ &
2040 & vbar_stokes(i,j+1)+ &
2041# endif
2042 & vbar(i,j+1,krhs))
2043 tl_cff1=0.5_r8*(tl_vbar(i,j ,krhs)+ &
2044# ifdef WEC_MELLOR
2045 & tl_vbar_stokes(i,j )+ &
2046 & tl_vbar_stokes(i,j+1)+ &
2047# endif
2048 & tl_vbar(i,j+1,krhs))
2049 cff2=0.5_r8*(ubar(i ,j,krhs)+ &
2050# ifdef WEC_MELLOR
2051 & ubar_stokes(i ,j)+ &
2052 & ubar_stokes(i+1,j)+ &
2053# endif
2054 & ubar(i+1,j,krhs))
2055 tl_cff2=0.5_r8*(tl_ubar(i ,j,krhs)+ &
2056# ifdef WEC_MELLOR
2057 & tl_ubar_stokes(i ,j)+ &
2058 & tl_ubar_stokes(i+1,j)+ &
2059# endif
2060 & tl_ubar(i+1,j,krhs))
2061 cff3=cff1*dndx(i,j)
2062 tl_cff3=tl_cff1*dndx(i,j)
2063 cff4=cff2*dmde(i,j)
2064 tl_cff4=tl_cff2*dmde(i,j)
2065 cff=drhs(i,j)*(cff3-cff4)
2066 tl_cff=tl_drhs(i,j)*(cff3-cff4)+ &
2067 & drhs(i,j)*(tl_cff3-tl_cff4)- &
2068# ifdef TL_IOMS
2069 & cff
2070# endif
2071!^ UFx(i,j)=cff*cff1
2072!^
2073 tl_ufx(i,j)=tl_cff*cff1+cff*tl_cff1- &
2074# ifdef TL_IOMS
2075 & cff*cff1
2076# endif
2077!^ VFe(i,j)=cff*cff2
2078!^
2079 tl_vfe(i,j)=tl_cff*cff2+cff*tl_cff2- &
2080# ifdef TL_IOMS
2081 & cff*cff2
2082# endif
2083# if defined DIAGNOSTICS_UV
2084!! cff=Drhs(i,j)*cff4
2085!! Uwrk(i,j)=-cff*cff1 ! ubar equation, ETA-term
2086!! Vwrk(i,j)=-cff*cff2 ! vbar equation, ETA-term
2087# endif
2088 END DO
2089 END DO
2090!
2091 DO j=jstr,jend
2092 DO i=istr,iend
2093 IF (i.ge.istru) THEN
2094 fac1=0.5_r8*(ufx(i,j)+ufx(i-1,j))
2095 rubar(i,j)=rubar(i,j)+fac1
2096# if defined DIAGNOSTICS_UV
2097!! fac2=0.5_r8*(Uwrk(i,j)+Uwrk(i-1,j))
2098!! DiaU2rhs(i,j,M2xadv)=DiaU2rhs(i,j,M2xadv)+fac1-fac2
2099!! DiaU2rhs(i,j,M2yadv)=DiaU2rhs(i,j,M2yadv)+fac2
2100!! DiaU2rhs(i,j,M2hadv)=DiaU2rhs(i,j,M2hadv)+fac1
2101# endif
2102 END IF
2103!
2104 IF (j.ge.jstrv) THEN
2105!^ fac1=0.5_r8*(VFe(i,j)+VFe(i,j-1))
2106!^
2107 tl_fac1=0.5_r8*(tl_ufx(i,j)+tl_ufx(i-1,j))
2108!^ rvbar(i,j)=rvbar(i,j)-fac1
2109!^
2110 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac1
2111# if defined DIAGNOSTICS_UV
2112!! fac2=0.5_r8*(Vwrk(i,j)+Vwrk(i,j-1))
2113!! DiaV2rhs(i,j,M2xadv)=DiaV2rhs(i,j,M2xadv)-fac1+fac2
2114!! DiaV2rhs(i,j,M2yadv)=DiaV2rhs(i,j,M2yadv)-fac2
2115!! DiaV2rhs(i,j,M2hadv)=DiaV2rhs(i,j,M2hadv)-fac1
2116# endif
2117 END IF
2118 END DO
2119 END DO
2120#endif
2121
2122#if defined UV_VIS2 && !defined SOLVE3D
2123!
2124!-----------------------------------------------------------------------
2125! Add in horizontal harmonic viscosity.
2126!-----------------------------------------------------------------------
2127!
2128! Compute total depth at PSI-points.
2129!
2130 DO j=jstr,jend+1
2131 DO i=istr,iend+1
2132 drhs_p(i,j)=0.25_r8*(drhs(i,j )+drhs(i-1,j )+ &
2133 & drhs(i,j-1)+drhs(i-1,j-1))
2134 tl_drhs_p(i,j)=0.25_r8*(tl_drhs(i,j )+tl_drhs(i-1,j )+ &
2135 & tl_drhs(i,j-1)+tl_drhs(i-1,j-1))
2136 END DO
2137 END DO
2138!
2139! Compute flux-components of the horizontal divergence of the stress
2140! tensor (m5/s2) in XI- and ETA-directions.
2141!
2142 DO j=jstrv-1,jend
2143 DO i=istru-1,iend
2144 cff=visc2_r(i,j)*drhs(i,j)*0.5_r8* &
2145 & (pmon_r(i,j)* &
2146 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2147 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2148 & pnom_r(i,j)* &
2149 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2150 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))
2151!
2152 tl_cff=visc2_r(i,j)*0.5_r8* &
2153 & (tl_drhs(i,j)* &
2154 & (pmon_r(i,j)* &
2155 & ((pn(i ,j)+pn(i+1,j))*ubar(i+1,j,krhs)- &
2156 & (pn(i-1,j)+pn(i ,j))*ubar(i ,j,krhs))- &
2157 & pnom_r(i,j)* &
2158 & ((pm(i,j )+pm(i,j+1))*vbar(i,j+1,krhs)- &
2159 & (pm(i,j-1)+pm(i,j ))*vbar(i,j ,krhs)))+ &
2160 & drhs(i,j)* &
2161 & (pmon_r(i,j)* &
2162 & ((pn(i ,j)+pn(i+1,j))*tl_ubar(i+1,j,krhs)- &
2163 & (pn(i-1,j)+pn(i ,j))*tl_ubar(i ,j,krhs))- &
2164 & pnom_r(i,j)* &
2165 & ((pm(i,j )+pm(i,j+1))*tl_vbar(i,j+1,krhs)- &
2166 & (pm(i,j-1)+pm(i,j ))*tl_vbar(i,j ,krhs))))- &
2167# ifdef TL_IOMS
2168 & cff
2169# endif
2170!^ UFx(i,j)=on_r(i,j)*on_r(i,j)*cff
2171!^
2172 tl_ufx(i,j)=on_r(i,j)*on_r(i,j)*tl_cff
2173!^ VFe(i,j)=om_r(i,j)*om_r(i,j)*cff
2174!^
2175 tl_vfe(i,j)=om_r(i,j)*om_r(i,j)*tl_cff
2176 END DO
2177 END DO
2178!
2179 DO j=jstr,jend+1
2180 DO i=istr,iend+1
2181 cff=visc2_p(i,j)*drhs_p(i,j)*0.5_r8* &
2182 & (pmon_p(i,j)* &
2183 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2184 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2185 & pnom_p(i,j)* &
2186 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2187 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))
2188!
2189 tl_cff=visc2_p(i,j)*0.5_r8* &
2190 & (tl_drhs_p(i,j)* &
2191 & (pmon_p(i,j)* &
2192 & ((pn(i ,j-1)+pn(i ,j))*vbar(i ,j,krhs)- &
2193 & (pn(i-1,j-1)+pn(i-1,j))*vbar(i-1,j,krhs))+ &
2194 & pnom_p(i,j)* &
2195 & ((pm(i-1,j )+pm(i,j ))*ubar(i,j ,krhs)- &
2196 & (pm(i-1,j-1)+pm(i,j-1))*ubar(i,j-1,krhs)))+ &
2197 & drhs_p(i,j)* &
2198 & (pmon_p(i,j)* &
2199 & ((pn(i ,j-1)+pn(i ,j))*tl_vbar(i ,j,krhs)- &
2200 & (pn(i-1,j-1)+pn(i-1,j))*tl_vbar(i-1,j,krhs))+ &
2201 & pnom_p(i,j)* &
2202 & ((pm(i-1,j )+pm(i,j ))*tl_ubar(i,j ,krhs)- &
2203 & (pm(i-1,j-1)+pm(i,j-1))*tl_ubar(i,j-1,krhs))))- &
2204# ifdef TL_IOMS
2205 & cff
2206# endif
2207# ifdef MASKING
2208!^ cff=cff*pmask(i,j)
2209!^
2210 tl_cff=tl_cff*pmask(i,j
2211# endif
2212# ifdef WET_DRY_NOT_YET
2213!^ cff=cff*pmask_wet(i,j)
2214!^
2215 tl_cff=tl_cff*pmask_wet(i,j)
2216# endif
2217!^ UFe(i,j)=om_p(i,j)*om_p(i,j)*cff
2218!^
2219 tl_ufe(i,j)=om_p(i,j)*om_p(i,j)*tl_cff
2220!^ VFx(i,j)=on_p(i,j)*on_p(i,j)*cff
2221!^
2222 tl_vfx(i,j)=on_p(i,j)*on_p(i,j)*tl_cff
2223 END DO
2224 END DO
2225!
2226! Add in harmonic viscosity.
2227!
2228 DO j=jstr,jend
2229 DO i=istr,iend
2230 IF (i.ge.istru) THEN
2231!^ cff1=0.5_r8*(pn(i-1,j)+pn(i,j))*(UFx(i,j )-UFx(i-1,j))
2232!^
2233 tl_cff1=0.5_r8*(pn(i-1,j)+pn(i,j))* &
2234 & (tl_ufx(i,j )-tl_ufx(i-1,j))
2235!^ cff2=0.5_r8*(pm(i-1,j)+pm(i,j))*(UFe(i,j+1)-UFe(i ,j))
2236!^
2237 tl_cff2=0.5_r8*(pm(i-1,j)+pm(i,j))* &
2238 & (tl_ufe(i,j+1)-tl_ufe(i ,j))
2239!^ fac=cff1+cff2
2240!^
2241 tl_fac=tl_cff1+tl_cff2
2242!^ rubar(i,j)=rubar(i,j)+fac
2243!^
2244 tl_rubar(i,j)=tl_rubar(i,j)+tl_fac
2245# if defined DIAGNOSTICS_UV
2246!! DiaU2rhs(i,j,M2hvis)=fac
2247!! DiaU2rhs(i,j,M2xvis)=cff1
2248!! DiaU2rhs(i,j,M2yvis)=cff2
2249# endif
2250 END IF
2251!
2252 IF (j.ge.jstrv) THEN
2253!^ cff1=0.5_r8*(pn(i,j-1)+pn(i,j))*(VFx(i+1,j)-VFx(i,j ))
2254!^
2255 tl_cff1=0.5_r8*(pn(i,j-1)+pn(i,j))* &
2256 & (tl_vfx(i+1,j)-tl_vfx(i,j ))
2257!^ cff2=0.5_r8*(pm(i,j-1)+pm(i,j))*(VFe(i ,j)-VFe(i,j-1))
2258!^
2259 tl_cff2=0.5_r8*(pm(i,j-1)+pm(i,j))* &
2260 & (tl_vfe(i ,j)-tl_vfe(i,j-1))
2261!^ fac=cff1-cff2
2262!^
2263 tl_fac=tl_cff1-tl_cff2
2264!^ rvbar(i,j)=rvbar(i,j)+fac
2265!^
2266 tl_rvbar(i,j)=tl_rvbar(i,j)+tl_fac
2267# if defined DIAGNOSTICS_UV
2268!! DiaV2rhs(i,j,M2hvis)=fac
2269!! DiaV2rhs(i,j,M2xvis)= cff1
2270!! DiaV2rhs(i,j,M2yvis)=-cff2
2271# endif
2272 END IF
2273 END DO
2274 END DO
2275#endif
2276
2277#ifndef SOLVE3D
2278!
2279!-----------------------------------------------------------------------
2280! Add in bottom stress.
2281!-----------------------------------------------------------------------
2282!
2283 DO j=jstr,jend
2284 DO i=istru,iend
2285!^ fac=bustr(i,j)*om_u(i,j)*on_u(i,j)
2286!^
2287 tl_fac=tl_bustr(i,j)*om_u(i,j)*on_u(i,j)
2288!^ rubar(i,j)=rubar(i,j)-fac
2289!^
2290 tl_rubar(i,j)=tl_rubar(i,j)-tl_fac
2291# ifdef DIAGNOSTICS_UV
2292!! DiaU2rhs(i,j,M2bstr)=-fac
2293# endif
2294 END DO
2295 END DO
2296 DO j=jstrv,jend
2297 DO i=istr,iend
2298!^ fac=bvstr(i,j)*om_v(i,j)*on_v(i,j)
2299!^
2300 tl_fac=tl_bvstr(i,j)*om_v(i,j)*on_v(i,j)
2301!^ rvbar(i,j)=rvbar(i,j)-fac
2302!^
2303 tl_rvbar(i,j)=tl_rvbar(i,j)-tl_fac
2304# ifdef DIAGNOSTICS_UV
2305!! DiaV2rhs(i,j,M2bstr)=-fac
2306# endif
2307 END DO
2308 END DO
2309#else
2310# ifdef DIAGNOSTICS_UV
2311!!
2312!! Initialize the stress term if no bottom friction is defined.
2313!!
2314!! DO j=Jstr,Jend
2315!! DO i=IstrU,Iend
2316!! DiaU2rhs(i,j,M2bstr)=0.0_r8
2317!! END DO
2318!! END DO
2319!! DO j=JstrV,Jend
2320!! DO i=Istr,Iend
2321!! DiaV2rhs(i,j,M2bstr)=0.0_r8
2322!! END DO
2323!! END DO
2324# endif
2325#endif
2326
2327#if defined RPM_RELAXATION && !defined SOLVE#D
2328!
2329!-----------------------------------------------------------------------
2330! Relaxe current representer tangent linear 2D momentum to previous
2331! Picard iteration solution (assumed constant over all barotropic
2332! timestep) to improve stability and convergence.
2333!-----------------------------------------------------------------------
2334!
2335! Compute flux-components of the diffusive relaxation (m4/s2) in XI-
2336! and ETA-directions.
2337!
2338 IF (tl_m2diff(ng).gt.0.0_r8) THEN
2339 DO j=jstr,jend
2340 DO i=istru-1,iend
2341 tl_ufx(i,j)=tl_m2diff(ng)*pmon_r(i,j)*drhs(i,j)* &
2342 & (tl_ubar(i+1,j,kstp)-ubar(i+1,j,kstp)- &
2343 & tl_ubar(i ,j,kstp)+ubar(i ,j,kstp))
2344 END DO
2345 END DO
2346 DO j=jstr,jend+1
2347 DO i=istru,iend
2348 tl_ufe(i,j)=tl_m2diff(ng)*pnom_p(i,j)*drhs_p(i,j)* &
2349 & (tl_ubar(i,j ,kstp)-ubar(i,j ,kstp)- &
2350 & tl_ubar(i,j-1,kstp)+ubar(i,j-1,kstp))
2351# ifdef MASKING
2352 tl_ufe(i,j)=tl_ufe(i,j)*pmask(i,j)
2353# endif
2354 END DO
2355 END DO
2356 DO j=jstrv,jend
2357 DO i=istr,iend+1
2358 tl_vfx(i,j)=tl_m2diff(ng)*pmon_p(i,j)*drhs_p(i,j)* &
2359 & (tl_vbar(i ,j,kstp)-vbar(i ,j,kstp)- &
2360 & tl_vbar(i-1,j,kstp)+vbar(i-1,j,kstp))
2361# ifdef MASKING
2362 tl_vfx(i,j)=tl_vfx(i,j)*pmask(i,j)
2363# endif
2364 END DO
2365 END DO
2366 DO j=jstrv-1,jend
2367 DO i=istr,iend
2368 tl_vfe(i,j)=tl_m2diff(ng)*pnom_r(i,j)*drhs(i,j)* &
2369 & (tl_vbar(i,j+1,kstp)-vbar(i,j+1,kstp)- &
2370 & tl_vbar(i,j ,kstp)+vbar(i,j ,kstp))
2371 END DO
2372 END DO
2373!
2374! Add in diffusion relaxation term.
2375!
2376 DO j=jstr,jend
2377 DO i=istru,iend
2378 tl_rubar(i,j)=tl_rubar(i,j)+ &
2379 & tl_ufx(i,j)-tl_ufx(i-1,j)+ &
2380 & tl_ufe(i,j+1)-tl_ufe(i,j)
2381 END DO
2382 END DO
2383 DO j=jstrv,jend
2384 DO i=istr,iend
2385 tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2386 & tl_vfx(i+1,j)-tl_vfx(i,j)+ &
2387 & tl_vfe(i,j)-tl_vfe(i,j-1)
2388
2389 END DO
2390 END DO
2391 END IF
2392#endif
2393
2394#ifdef SOLVE3D
2395!
2396!-----------------------------------------------------------------------
2397! Coupling between 2D and 3D equations.
2398!-----------------------------------------------------------------------
2399!
2400! Before the predictor step of the first barotropic time step, arrays
2401! "rufrc" and "rvfrc" contain vertical integrals of the 3D RHS terms
2402! for the momentum equations (including surface and bottom stresses,
2403! if so prescribed). During the first barotropic time step, convert
2404! them into forcing terms by subtracting the fast-time "rubar" and
2405! "rvbar" from them.
2406!
2407! These forcing terms are then extrapolated forward in time using
2408! optimized Adams-Bashforth weights, so that the resultant "rufrc"
2409! and "rvfrc" are centered effectively at time n+1/2 in baroclinic
2410! time.
2411!
2412! From now on, these newly computed forcing terms remain unchanged
2413! during the fast time stepping and will be added to "rubar" and
2414! "rvbar" during all subsequent barotropic time steps.
2415!
2416! Thus, the algorithm below is designed for coupling during the 3D
2417! predictor sub-step. The forcing terms "rufrc" and "rvfrc" are
2418! computed as instantaneous values at 3D time index "nstp" first and
2419! then extrapolated half-step forward using AM3-like weights optimized
2420! for maximum stability (with particular care for startup).
2421!
2422 IF (first_2d_step.and.predictor_2d_step) THEN
2423 IF (first_time_step) THEN
2424 cff3=0.0_r8
2425 cff2=0.0_r8
2426 cff1=1.0_r8
2427 ELSE IF (first_time_step+1) THEN
2428 cff3=0.0_r8
2429 cff2=-0.5_r8
2430 cff1=1.5_r8
2431 ELSE
2432 cff3=0.281105_r8
2433 cff2=-0.5_r8-2.0_r8*cff3
2434 cff1=1.5_r8+cff3
2435 END IF
2436!
2437 DO j=jstr,jend
2438 DO i=istru,iend
2439!^ cff=rufrc(i,j)-rubar(i,j)
2440!^
2441 tl_cff=tl_rufrc(i,j)-tl_rubar(i,j)
2442!^ rufrc(i,j)=cff1*cff+ &
2443!^ & cff2*rufrc_bak(i,j,3-nstp)+ &
2444!^ & cff3*rufrc_bak(i,j,nstp )
2445!^
2446 tl_rufrc(i,j)=cff1*tl_cff+ &
2447 & cff2*tl_rufrc_bak(i,j,3-nstp)+ &
2448 & cff3*tl_rufrc_bak(i,j,nstp )
2449!^ rufrc_bak(i,j,nstp)=cff
2450!^
2451 tl_rufrc_bak(i,j,nstp)=tl_cff
2452 END DO
2453 END DO
2454 DO j=jstrv,jend
2455 DO i=istr,iend
2456!^ cff=rvfrc(i,j)-rvbar(i,j)
2457!^
2458 tl_cff=tl_rvfrc(i,j)-tl_rvbar(i,j)
2459!^ rvfrc(i,j)=cff1*cff+ &
2460!^ & cff2*rvfrc_bak(i,j,3-nstp)+ &
2461!^ & cff3*rvfrc_bak(i,j,nstp )
2462!^
2463 tl_rvfrc(i,j)=cff1*tl_cff+ &
2464 & cff2*tl_rvfrc_bak(i,j,3-nstp)+ &
2465 & cff3*tl_rvfrc_bak(i,j,nstp )
2466!^ rvfrc_bak(i,j,nstp)=cff
2467!^
2468 tl_rvfrc_bak(i,j,nstp)=tl_cff
2469 END DO
2470 END DO
2471!
2472! Since coupling requires that the pressure gradient term is computed
2473! using zeta(:,:,kstp) instead of 1/3 toward zeta_new(:,:) as needed
2474! by generalized RK2 scheme, apply compensation to shift pressure
2475! gradient terms from "kstp" to 1/3 toward "knew".
2476!
2477 cff1=0.5_r8*g
2478 cff2=0.333333333333_r8
2479 cff3=1.666666666666_r8
2480
2481 DO j=jstrv-1,jend
2482 DO i=istru-1,iend
2483!^ zwrk(i,j)=cff2*(zeta_new(i,j)-zeta(i,j,kstp))
2484!^
2485 tl_zwrk(i,j)=cff2*(tl_zeta_new(i,j)-tl_zeta(i,j,kstp))
2486# if defined VAR_RHO_2D && defined SOLVE3D
2487!^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j)
2488!^
2489 tl_rzeta(i,j)=(1.0_r8+rhos(i,j))*tl_zwrk(i,j)+ &
2490 & tl_rhos(i,j)+zwrk(i,j)- &
2491# ifdef TL_IOMS
2492 & rhos(i,j)*zwrk(i,j)
2493# endif
2494!^ rzeta2(i,j)=rzeta(i,j)* &
2495!^ & (cff2*zeta_new(i,j)+ &
2496!^ & cff3*zeta(i,j,kstp))
2497!^
2498 tl_rzeta2(i,j)=tl_rzeta(i,j)* &
2499 & (cff2*zeta_new(i,j)+ &
2500 & cff3*zeta(i,j,kstp))+ &
2501 & rzeta(i,j)* &
2502 & (cff2*zeta_new(i,j)+ &
2503 & cff3*zeta(i,j,kstp))- &
2504# ifdef TL_IOMS
2505 & rzeta2(i,j)
2506# endif
2507!^ rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))
2508!^
2509 tl_rzetasa(i,j)=tl_zwrk(i,j)* &
2510 & (rhos(i,j)-rhoa(i,j))+ &
2511 & zwrk(i,j)* &
2512 & (tl_rhos(i,j)-tl_rhoa(i,j))- &
2513# ifdef TL_IOMS
2514 & rzetasa(i,j)
2515# endif
2516# else
2517!^ rzeta(i,j)=zwrk(i,j)
2518!^
2519 tl_rzeta(i,j)=tl_zwrk(i,j)
2520!^ rzeta2(i,j)=zwrk(i,j)* &
2521!^ & (cff2*zeta_new(i,j)+ &
2522!^ & cff3*zeta(i,j,kstp))
2523!^
2524 tl_rzeta2(i,j)=tl_zwrk(i,j)* &
2525 & (cff2*zeta_new(i,j)+ &
2526 & cff3*zeta(i,j,kstp))+ &
2527 & zwrk(i,j)* &
2528 & (cff2*tl_zeta_new(i,j)+ &
2529 & cff3*tl_zeta(i,j,kstp))- &
2530# ifdef TL_IOMS
2531 & rzeta2(i,j)
2532# endif
2533# endif
2534 END DO
2535 END DO
2536!
2537 DO j=jstr,jend
2538 DO i=istr,iend
2539 IF (i.ge.istru) THEN
2540!^ rubar(i,j)=rubar(i,j)+ &
2541!^ & cff1*on_u(i,j)* &
2542!^ & ((h(i-1,j)+ &
2543!^ & h(i ,j))* &
2544!^ & (rzeta(i-1,j)- &
2545!^ & rzeta(i ,j))+ &
2546# if defined VAR_RHO_2D && defined SOLVE3D
2547!^ & (h(i-1,j)- &
2548!^ & h(i ,j))* &
2549!^ & (rzetaSA(i-1,j)+ &
2550!^ & rzetaSA(i ,j)+ &
2551!^ & cff2*(rhoA(i-1,j)- &
2552!^ & rhoA(i ,j))* &
2553!^ & (zwrk(i-1,j)- &
2554!^ & zwrk(i ,j)))+ &
2555# endif
2556!^ & (rzeta2(i-1,j)- &
2557!^ & rzeta2(i ,j)))
2558!^
2559 tl_rubar(i,j)=tl_rubar(i,j)+ &
2560 & cff1*on_u(i,j)* &
2561 & ((h(i-1,j)+ &
2562 & h(i ,j))* &
2563 & (tl_rzeta(i-1,j)- &
2564 & tl_rzeta(i ,j))+ &
2565# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2566 & (tl_h(i-1,j)+ &
2567 & tl_h(i ,j))* &
2568 & (rzeta(i-1,j)- &
2569 & rzeta(i ,j))- &
2570# ifdef TL_IOMS
2571 & (h(i-1,j)+ &
2572 & h(i ,j))* &
2573 & (rzeta(i-1,j)- &
2574 & rzeta(i ,j))+ &
2575# endif
2576# endif
2577# if defined VAR_RHO_2D && defined SOLVE3D
2578# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2579 & (tl_h(i-1,j)- &
2580 & tl_h(i ,j))* &
2581 & (rzetasa(i-1,j)+ &
2582 & rzetasa(i ,j)+ &
2583 & cff2*(rhoa(i-1,j)- &
2584 & rhoa(i ,j))* &
2585 & (zwrk(i-1,j)- &
2586 & zwrk(i ,j)))+ &
2587# endif
2588 & (h(i-1,j)- &
2589 & h(i ,j))* &
2590 & (tl_rzetasa(i-1,j)+ &
2591 & tl_rzetasa(i ,j)+ &
2592 & cff2*((tl_rhoa(i-1,j)- &
2593 & tl_rhoa(i ,j))* &
2594 & (zwrk(i-1,j)- &
2595 & zwrk(i ,j))+ &
2596 & (rhoa(i-1,j)- &
2597 & rhoa(i ,j))* &
2598 & (tl_zwrk(i-1,j)- &
2599 & tl_zwrk(i ,j))))- &
2600# ifdef TL_IOMS
2601# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2602 & (h(i-1,j)- &
2603 & h(i ,j))* &
2604 & (rzetasa(i-1,j)+ &
2605 & rzetasa(i ,j))- &
2606 & 2.0_r8* &
2607# endif
2608 & (h(i-1,j)- &
2609 & h(i ,j))* &
2610 & (cff2*(rhoa(i-1,j)- &
2611 & rhoa(i ,j))* &
2612 & (zwrk(i-1,j)- &
2613 & zwrk(i ,j)))+ &
2614# endif
2615# endif
2616 & (tl_rzeta2(i-1,j)- &
2617 & tl_rzeta2(i ,j)))
2618# ifdef DIAGNOSTICS_UV
2619!! DiaU2rhs(i,j,M2pgrd)=DiaU2rhs(i,j,M2pgrd)+ &
2620!! & rubar(i,j)
2621# endif
2622 END IF
2623!
2624 IF (j.ge.jstrv) THEN
2625!^ rvbar(i,j)=rvbar(i,j)+ &
2626!^ & cff1*om_v(i,j)* &
2627!^ & ((h(i,j-1)+ &
2628!^ & h(i,j ))* &
2629!^ & (rzeta(i,j-1)- &
2630!^ & rzeta(i,j ))+ &
2631# if defined VAR_RHO_2D && defined SOLVE3D
2632!^ & (h(i,j-1)- &
2633!^ & h(i,j ))* &
2634!^ & (rzetaSA(i,j-1)+ &
2635!^ & rzetaSA(i,j )+ &
2636!^ & cff2*(rhoA(i,j-1)- &
2637!^ & rhoA(i,j ))* &
2638!^ & (zwrk(i,j-1)- &
2639!^ & zwrk(i,j )))+ &
2640# endif
2641!^ & (rzeta2(i,j-1)- &
2642!^ & rzeta2(i,j )))
2643!^
2644 tl_rvbar(i,j)=tl_rvbar(i,j)+ &
2645 & cff1*om_v(i,j)* &
2646 & ((h(i,j-1)+ &
2647 & h(i,j ))* &
2648 & (tl_rzeta(i,j-1)- &
2649 & tl_rzeta(i,j ))+ &
2650# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2651 & (tl_h(i,j-1)+ &
2652 & tl_h(i,j ))* &
2653 & (rzeta(i,j-1)- &
2654 & rzeta(i,j ))- &
2655# ifdef TL_IOMS
2656 & (h(i,j-1)+ &
2657 & h(i,j ))* &
2658 & (rzeta(i,j-1)- &
2659 & rzeta(i,j ))+ &
2660# endif
2661# endif
2662# if defined VAR_RHO_2D && defined SOLVE3D
2663# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2664 & (tl_h(i,j-1)- &
2665 & tl_h(i,j ))* &
2666 & (rzetasa(i,j-1)+ &
2667 & rzetasa(i,j )+ &
2668 & cff2*(rhoa(i,j-1)- &
2669 & rhoa(i,j ))* &
2670 & (zwrk(i,j-1)- &
2671 & zwrk(i,j )))+ &
2672# endif
2673 & (h(i,j-1)- &
2674 & h(i,j ))* &
2675 & (tl_rzetasa(i,j-1)+ &
2676 & tl_rzetasa(i,j )+ &
2677 & cff2*((tl_rhoa(i,j-1)- &
2678 & tl_rhoa(i,j ))* &
2679 & (zwrk(i,j-1)- &
2680 & zwrk(i,j ))+ &
2681 & (rhoa(i,j-1)- &
2682 & rhoa(i,j ))* &
2683 & (tl_zwrk(i,j-1)- &
2684 & tl_zwrk(i,j ))))- &
2685# ifdef TL_IOMS
2686# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET
2687 & (h(i,j-1)- &
2688 & h(i,j ))* &
2689 & (rzetasa(i,j-1)+ &
2690 & rzetasa(i,j ))- &
2691 & 2.0_r8* &
2692# endif
2693 & (h(i,j-1)- &
2694 & h(i,j ))* &
2695 & (cff2*(rhoa(i,j-1)- &
2696 & rhoa(i,j ))* &
2697 & (zwrk(i,j-1)- &
2698 & zwrk(i,j )))+ &
2699# endif
2700# endif
2701 & (tl_rzeta2(i,j-1)- &
2702 & tl_rzeta2(i,j )))
2703# ifdef DIAGNOSTICS_UV
2704!! DiaV2rhs(i,j,M2pgrd)=DiaV2rhs(i,j,M2pgrd)+ &
2705!! & rvbar(i,j)
2706# endif
2707 END IF
2708 END DO
2709 END DO
2710 END IF
2711#endif
2712!
2713!=======================================================================
2714! Time step 2D momentum equations.
2715!=======================================================================
2716!
2717! Compute total water column depth.
2718!
2719 IF (first_2d_step.or.(.not.predictor_2d_step)) THEN
2720 DO j=jstrv-1,jend
2721 DO i=istru-1,iend
2722!^ Dstp(i,j)=h(i,j)+zeta(i,j,kstp)
2723!^
2724 tl_dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kstp)
2725 END DO
2726 END DO
2727 ELSE
2728 DO j=jstrv-1,jend
2729 DO i=istru-1,iend
2730!^ Dstp(i,j)=h(i,j)+zeta(i,j,kbak)
2731!^
2732 tl_dstp(i,j)=tl_h(i,j)+tl_zeta(i,j,kbak)
2733 END DO
2734 END DO
2735 END IF
2736!
2737! During the predictor sub-step, once newly computed "ubar" and "vbar"
2738! become available, interpolate them half-step backward in barotropic
2739! time (i.e., they end up time-centered at n+1/2) in order to use it
2740! during subsequent corrector sub-step.
2741!
2742 IF (predictor_2d_step) THEN
2743 IF (first_2d_step) THEN
2744 cff1=0.5_r8*dtfast(ng)
2745 cff2=0.5_r8
2746 cff3=0.5_r8
2747 cff4=0.0_r8
2748 ELSE
2749 cff1=dtfast(ng)
2750 cff2=0.5_r8-gamma
2751 cff3=0.5_r8+2.0_r8*gamma
2752 cff4=-gamma
2753 ENDIF
2754!
2755 DO j=jstr,jend
2756 DO i=istru,iend
2757 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
2758 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
2759 tl_fac1=-fac1*fac1*(tl_dnew(i,j)+tl_dnew(i-1,j))
2760!^ ubar(i,j,knew)=fac1* &
2761!^ & (ubar(i,j,kbak)* &
2762!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2763#ifdef SOLVE3D
2764!^ & cff*(rubar(i,j)+rufrc(i,j)))
2765#else
2766!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
2767#endif
2768!^
2769 tl_ubar(i,j,knew)=tl_fac1* &
2770 & (ubar(i,j,kbak)* &
2771 & (dstp(i,j)+dstp(i-1,j))+ &
2772#ifdef SOLVE3D
2773 & cff*(rubar(i,j)+rufrc(i,j)))+ &
2774#else
2775 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
2776#endif
2777 & fac1* &
2778 & (tl_ubar(i,j,kbak)* &
2779 & (dstp(i,j)+dstp(i-1,j))+ &
2780 & ubar(i,j,kbak)* &
2781 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
2782#ifdef SOLVE3D
2783 & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))- &
2784# ifdef TL_IOMS
2785 & fac1* &
2786 & (2.0_r8*ubar(i,j,kbak)* &
2787 & (dstp(i,j)+dstp(i-1,j))+ &
2788 & cff*(rubar(i,j)+rufrc(i,j)))
2789# endif
2790#else
2791 & cff*tl_rubar(i,j)+ &
2792 & 4.0_r8*cff1*tl_sustr(i,j))- &
2793# ifdef TL_IOMS
2794 & fac1* &
2795 & (2.0_r8*ubar(i,j,kstp)* &
2796 & (dstp(i,j)+dstp(i-1,j))+ &
2797 & cff*rubar(i,j)+cff1*sustr(i,j))
2798# endif
2799#endif
2800#ifdef MASKING
2801!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
2802!^
2803 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
2804#endif
2805!^ ubar(i,j,knew)=cff2*ubar(i,j,knew)+ &
2806!^ & cff3*ubar(i,j,kstp)+ &
2807!^ & cff4*ubar(i,j,kbak)
2808!^
2809 tl_ubar(i,j,knew)=cff2*tl_ubar(i,j,knew)+ &
2810 & cff3*tl_ubar(i,j,kstp)+ &
2811 & cff4*tl_ubar(i,j,kbak)
2812#ifdef WET_DRY_NOT_YET
2813!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
2814!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
2815!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2816!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
2817!^
2818!^ HGA: TLM code needed here.
2819!^
2820#endif
2821#if defined NESTING && !defined SOLVE3D
2822!^ DU_flux(i,j)=0.5_r8*on_u(i,j)* &
2823!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2824!^
2825 tl_du_flux(i,j)=0.5_r8*on_u(i,j)* &
2826 & ((dnew(i,j)+dnew(i-1,j))* &
2827 & tl_ubar(i,j,knew)+ &
2828 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2829 & ubar(i,j,knew))- &
2830# ifdef TL_IOMS
2831 & 0.5_r8*on_u(i,j)* &
2832 & (dnew(i,j)+dnew(i-1,j))* &
2833 & ubar(i,j,knew)
2834# endif
2835#endif
2836 END DO
2837 END DO
2838!
2839 DO j=jstrv,jend
2840 DO i=istr,iend
2841 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
2842 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
2843 tl_fac2=-fac2*fac2*(tl_dnew(i,j)+tl_dnew(i,j-1))
2844!^ vbar(i,j,knew)=fac2* &
2845!^ & (vbar(i,j,kbak)* &
2846!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
2847#ifdef SOLVE3D
2848!^ & cff*(rvbar(i,j)+rvfrc(i,j)))
2849#else
2850!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
2851#endif
2852!^
2853 tl_vbar(i,j,knew)=tl_fac2* &
2854 & (vbar(i,j,kbak)* &
2855 & (dstp(i,j)+dstp(i,j-1))+ &
2856#ifdef SOLVE3D
2857 & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
2858#else
2859 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
2860#endif
2861 & fac2* &
2862 & (tl_vbar(i,j,kbak)* &
2863 & (dstp(i,j)+dstp(i,j-1))+ &
2864 & vbar(i,j,kbak)* &
2865 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
2866#ifdef SOLVE3D
2867 & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))- &
2868# ifdef TL_IOMS
2869 & fac2* &
2870 & (2.0_r8*vbar(i,j,kbak)* &
2871 & (dstp(i,j)+dstp(i,j-1))+ &
2872 & cff*(rvbar(i,j)+rvfrc(i,j)))
2873# endif
2874#else
2875 & cff*tl_rvbar(i,j)+ &
2876 & 4.0_r8*cff1*tl_svstr(i,j))- &
2877# ifdef TL_IOMS
2878 & fac2* &
2879 & (2.0_r8*vbar(i,j,kstp)* &
2880 & (dstp(i,j)+dstp(i,j-1))+ &
2881 & cff*rvbar(i,j)+cff1*svstr(i,j))
2882# endif
2883#endif
2884#ifdef MASKING
2885!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
2886!^
2887 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
2888#endif
2889!^ vbar(i,j,knew)=cff2*vbar(i,j,knew)+ &
2890!^ & cff3*vbar(i,j,kstp)+ &
2891!^ & cff4*vbar(i,j,kbak)
2892!^
2893 tl_vbar(i,j,knew)=cff2*tl_vbar(i,j,knew)+ &
2894 & cff3*tl_vbar(i,j,kstp)+ &
2895 & cff4*tl_vbar(i,j,kbak)
2896#ifdef WET_DRY_NOT_YET
2897!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
2898!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
2899!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2900!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
2901!^
2902!^ HGA: TLM code needed here.
2903!^
2904#endif
2905#if defined NESTING && !defined SOLVE3D
2906!^ DV_flux(i,j)=0.5_r8*om_v(i,j)* &
2907!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
2908!^
2909 tl_dv_flux(i,j)=0.5_r8*om_v(i,j)* &
2910 & ((dnew(i,j)+dnew(i,j-1))* &
2911 & tl_vbar(i,j,knew)+ &
2912 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
2913 & vbar(i,j,knew))- &
2914# ifdef TL_IOMS
2915 & 0.5_r8*om_v(i,j)* &
2916 & (dnew(i,j)+dnew(i,j-1))* &
2917 & vbar(i,j,knew)
2918# endif
2919#endif
2920 END DO
2921 END DO
2922
2923 ELSE !--> CORRECTOR_2D_STEP
2924
2925 cff1=0.5_r8*dtfast(ng)
2926 DO j=jstr,jend
2927 DO i=istru,iend
2928 cff=cff1*(pm(i,j)+pm(i-1,j))*(pn(i,j)+pn(i-1,j))
2929 fac1=1.0_r8/(dnew(i,j)+dnew(i-1,j))
2930 tl_fac1=-fac1*fac1*(dnew(i,j)+dnew(i-1,j))
2931!^ ubar(i,j,knew)=fac1* &
2932!^ & (ubar(i,j,kstp)* &
2933!^ & (Dstp(i,j)+Dstp(i-1,j))+ &
2934#ifdef SOLVE3D
2935!^ & cff*(rubar(i,j)+rufrc(i,j)))
2936#else
2937!^ & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))
2938#endif
2939!^
2940 tl_ubar(i,j,knew)=tl_fac1* &
2941 & (ubar(i,j,kstp)* &
2942 & (dstp(i,j)+dstp(i-1,j))+ &
2943#ifdef SOLVE3D
2944 & cff*(rubar(i,j)+rufrc(i,j)))+ &
2945#else
2946 & cff*rubar(i,j)+4.0_r8*cff1*sustr(i,j))+ &
2947#endif
2948 & fac1* &
2949 & (tl_ubar(i,j,kstp)* &
2950 & (dstp(i,j)+dstp(i-1,j))+ &
2951 & ubar(i,j,kstp)* &
2952 & (tl_dstp(i,j)+tl_dstp(i-1,j))+ &
2953#ifdef SOLVE3D
2954 & cff*(tl_rubar(i,j)+tl_rufrc(i,j)))- &
2955# ifdef TL_IOMS
2956 & fac1* &
2957 & (2.0_r8*ubar(i,j,kstp)* &
2958 & (dstp(i,j)+dstp(i-1,j))+ &
2959 & cff*(rubar(i,j)+rufrc(i,j)))
2960# endif
2961#else
2962 & cff*tl_rubar(i,j)+ &
2963 & 4.0_r8*cff1*tl_sustr(i,j))- &
2964# ifdef TL_IOMS
2965 & fac1* &
2966 & (2.0_r8*ubar(i,j,kstp)* &
2967 & (dstp(i,j)+dstp(i-1,j))+ &
2968 & cff*rubar(i,j)+cff1*sustr(i,j))
2969# endif
2970#endif
2971#ifdef MASKING
2972!^ ubar(i,j,knew)=ubar(i,j,knew)*umask(i,j)
2973!^
2974 tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask(i,j)
2975#endif
2976#ifdef WET_DRY_NOT_YET
2977!^ cff5=ABS(ABS(umask_wet(i,j))-1.0_r8)
2978!^ cff6=0.5_r8+DSIGN(0.5_r8,ubar(i,j,knew))*umask_wet(i,j)
2979!^ cff7=0.5_r8*umask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
2980!^ ubar(i,j,knew)=ubar(i,j,knew)*cff7
2981!^
2982!^ HGA: TLM code needed here.
2983!^
2984#endif
2985#if defined NESTING && !defined SOLVE3D
2986!^ DU_flux(i,j)=0.5_r8*on_u(i,j)* &
2987!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
2988!^
2989 tl_du_flux(i,j)=0.5_r8*on_u(i,j)* &
2990 & ((dnew(i,j)+dnew(i-1,j))* &
2991 & tl_ubar(i,j,knew)+ &
2992 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
2993 & ubar(i,j,knew))- &
2994# ifdef TL_IOMS
2995 & 0.5_r8*on_u(i,j)* &
2996 & (dnew(i,j)+dnew(i-1,j))* &
2997 & ubar(i,j,knew)
2998# endif
2999#endif
3000 END DO
3001 END DO
3002!
3003 DO j=jstrv,jend
3004 DO i=istr,iend
3005 cff=cff1*(pm(i,j)+pm(i,j-1))*(pn(i,j)+pn(i,j-1))
3006 fac2=1.0_r8/(dnew(i,j)+dnew(i,j-1))
3007 tl_fac2=-fac2*fac2*(tl_dnew(i,j)+tl_dnew(i,j-1))
3008!^ vbar(i,j,knew)=fac2* &
3009!^ & (vbar(i,j,kstp)* &
3010!^ & (Dstp(i,j)+Dstp(i,j-1))+ &
3011#ifdef SOLVE3D
3012!^ & cff*(rvbar(i,j)+rvfrc(i,j)))
3013#else
3014!^ & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))
3015#endif
3016!^
3017 tl_vbar(i,j,knew)=tl_fac2* &
3018 & (vbar(i,j,kstp)* &
3019 & (dstp(i,j)+dstp(i,j-1))+ &
3020#ifdef SOLVE3D
3021 & cff*(rvbar(i,j)+rvfrc(i,j)))+ &
3022#else
3023 & cff*rvbar(i,j)+4.0_r8*cff1*svstr(i,j))+ &
3024#endif
3025 & fac2* &
3026 & (tl_vbar(i,j,kstp)* &
3027 & (dstp(i,j)+dstp(i,j-1))+ &
3028 & vbar(i,j,kstp)* &
3029 & (tl_dstp(i,j)+tl_dstp(i,j-1))+ &
3030#ifdef SOLVE3D
3031 & cff*(tl_rvbar(i,j)+tl_rvfrc(i,j)))- &
3032# ifdef TL_IOMS
3033 & fac2* &
3034 & (2.0_r8*vbar(i,j,kstp)* &
3035 & (dstp(i,j)+dstp(i,j-1))+ &
3036 & cff*(rvbar(i,j)+rvfrc(i,j)))
3037# endif
3038#else
3039 & cff*tl_rvbar(i,j)+ &
3040 & 4.0_r8*cff1*svstr(i,j))- &
3041# ifdef TL_IOMS
3042 & fac2* &
3043 & (2.0_r8*vbar(i,j,kstp)* &
3044 & (dstp(i,j)+dstp(i,j-1))+ &
3045 & cff*rvbar(i,j)+cff1*svstr(i,j))
3046# endif
3047#endif
3048#ifdef MASKING
3049!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask(i,j)
3050!^
3051 tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask(i,j)
3052#endif
3053#ifdef WET_DRY_NOT_YET
3054!^ cff5=ABS(ABS(vmask_wet(i,j))-1.0_r8)
3055!^ cff6=0.5_r8+DSIGN(0.5_r8,vbar(i,j,knew))*vmask_wet(i,j)
3056!^ cff7=0.5_r8*vmask_wet(i,j)*cff5+cff6*(1.0_r8-cff5)
3057!^ vbar(i,j,knew)=vbar(i,j,knew)*cff7
3058!^
3059!^ HGA: TLM code needed here.
3060!^
3061#endif
3062#if defined NESTING && !defined SOLVE3D
3063!^ DV_flux(i,j)=0.5_r8*om_v(i,j)* &
3064!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
3065!^
3066 tl_dv_flux(i,j)=0.5_r8*om_v(i,j)* &
3067 & ((dnew(i,j)+dnew(i,j-1))* &
3068 & tl_vbar(i,j,knew)+ &
3069 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
3070 & vbar(i,j,knew))- &
3071# ifdef TL_IOMS
3072 & 0.5_r8*om_v(i,j)* &
3073 & (dnew(i,j)+dnew(i,j-1))* &
3074 & vbar(i,j,knew)
3075# endif
3076#endif
3077 END DO
3078 END DO
3079 END IF
3080!
3081! Apply lateral boundary conditions.
3082!
3083!^ CALL u2dbc_tile (ng, tile, &
3084!^ & LBi, UBi, LBj, UBj, &
3085!^ & IminS, ImaxS, JminS, JmaxS, &
3086!^ & krhs, kstp, knew, &
3087!^ & ubar, vbar, zeta)
3088!^
3089 CALL rp_u2dbc_tile (ng, tile, &
3090 & lbi, ubi, lbj, ubj, &
3091 & imins, imaxs, jmins, jmaxs, &
3092 & krhs, kstp, knew, &
3093 & ubar, vbar, zeta, &
3094 & tl_ubar, tl_vbar, tl_zeta)
3095!^ CALL v2dbc_tile (ng, tile, &
3096!^ & LBi, UBi, LBj, UBj, &
3097!^ & IminS, ImaxS, JminS, JmaxS, &
3098!^ & krhs, kstp, knew, &
3099!^ & ubar, vbar, zeta)
3100!^
3101 CALL rp_v2dbc_tile (ng, tile, &
3102 & lbi, ubi, lbj, ubj, &
3103 & imins, imaxs, jmins, jmaxs, &
3104 & krhs, kstp, knew, &
3105 & ubar, vbar, zeta, &
3106 & tl_ubar, tl_vbar, tl_zeta)
3107!
3108! Compute integral mass flux across open boundaries and adjust
3109! for volume conservation.
3110!
3111 IF (any(volcons(:,ng))) THEN
3112!^ CALL obc_flux_tile (ng, tile, &
3113!^ & LBi, UBi, LBj, UBj, &
3114!^ & IminS, ImaxS, JminS, JmaxS, &
3115!^ & knew, &
3116#ifdef MASKING
3117!^ & umask, vmask, &
3118#endif
3119!^ & h, om_v, on_u, &
3120!^ & ubar, vbar, zeta)
3121!^
3122 CALL rp_obc_flux_tile (ng, tile, &
3123 & lbi, ubi, lbj, ubj, &
3124 & imins, imaxs, jmins, jmaxs, &
3125 & knew, &
3126#ifdef MASKING
3127 & umask, vmask, &
3128#endif
3129 & h, tl_h, om_v, on_u, &
3130 & ubar, vbar, zeta, &
3131 & tl_ubar, tl_vbar, tl_zeta)
3132 END IF
3133
3134#if defined NESTING && !defined SOLVE3D
3135!
3136! Set barotropic fluxes along physical boundaries.
3137!
3138 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3139 IF (domain(ng)%Western_Edge(tile)) THEN
3140 DO j=jstr-1,jendr
3141!^ Dnew(Istr-1,j)=h(Istr-1,j)+zeta_new(Istr-1,j)
3142!^
3143 tl_dnew(istr-1,j)=tl_h(istr-1,j)+tl_zeta_new(istr-1,j)
3144 END DO
3145 END IF
3146 END IF
3147 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3148 IF (domain(ng)%Eastern_Edge(tile)) THEN
3149 DO j=jstr-1,jendr
3150!^ Dnew(Iend+1,j)=h(Iend+1,j)+zeta_new(Iend+1,j)
3151!^
3152 tl_dnew(iend+1,j)=tl_h(iend+1,j)+tl_zeta_new(iend+1,j)
3153 END DO
3154 END IF
3155 END IF
3156 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3157 IF (domain(ng)%Southern_Edge(tile)) THEN
3158 DO i=istr-1,iendr
3159!^ Dnew(i,Jstr-1)=h(i,Jstr-1)+zeta_new(i,Jstr-1)
3160!^
3161 tl_dnew(i,jstr-1)=tl_h(i,jstr-1)+tl_zeta_new(i,jstr-1)
3162 END DO
3163 END IF
3164 END IF
3165 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3166 IF (domain(ng)%Northern_Edge(tile)) THEN
3167 DO i=istr-1,iendr
3168!^ Dnew(i,Jend+1)=h(i,Jend+1)+zeta_new(i,Jend+1)
3169!^
3170 tl_dnew(i,jend+1)=tl_h(i,jend+1)+tl_zeta_new(i,jend+1)
3171 END DO
3172 END IF
3173 END IF
3174!
3175 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3176 IF (domain(ng)%Western_Edge(tile)) THEN
3177 DO j=jstrr,jendr
3178!^ DU_flux(IstrU-1,j)=0.5_r8*on_u(IstrU-1,j)* &
3179!^ & (Dnew(IstrU-1,j)+Dnew(IstrU-2,j))* &
3180!^ & ubar(IstrU-1,j,knew)
3181!^
3182 tl_du_flux(istru-1,j)=0.5_r8*on_u(istru-1,j)* &
3183 & ((dnew(istru-1,j)+ &
3184 & dnew(istru-2,j))* &
3185 & tl_ubar(istru-1,j,knew)+ &
3186 & (tl_dnew(istru-1,j)+ &
3187 & tl_dnew(istru-2,j))* &
3188 & ubar(istru-1,j,knew))- &
3189# ifdef TL_IOMS
3190 & 0.5_r8*on_u(istru-1,j)* &
3191 & (dnew(istru-1,j)+dnew(istru-2,j))* &
3192 & ubar(istru-1,j,knew)
3193# endif
3194 END DO
3195 DO j=jstrv,jend
3196!^ DV_flux(Istr-1,j)=0.5_r8*om_v(Istr-1,j)* &
3197!^ & (Dnew(Istr-1,j)+Dnew(Istr-1,j-1))* &
3198!^ & vbar(Istr-1,j,knew)
3199!^
3200 tl_dv_flux(istr-1,j)=0.5_r8*om_v(istr-1,j)* &
3201 & ((dnew(istr-1,j )+ &
3202 & dnew(istr-1,j-1))* &
3203 & tl_vbar(istr-1,j,knew)+ &
3204 & (tl_dnew(istr-1,j )+ &
3205 & tl_dnew(istr-1,j-1))* &
3206 & vbar(istr-1,j,knew))- &
3207# ifdef TL_IOMS
3208 & 0.5_r8*om_v(istr-1,j)* &
3209 & (dnew(istr-1,j)+dnew(istr-1,j-1))* &
3210 & vbar(istr-1,j,knew)
3211# endif
3212 END DO
3213 END IF
3214 END IF
3215 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3216 IF (domain(ng)%Eastern_Edge(tile)) THEN
3217 DO j=jstrr,jendr
3218!^ DU_flux(Iend+1,j)=0.5_r8*on_u(Iend+1,j)* &
3219!^ & (Dnew(Iend+1,j)+Dnew(Iend,j))* &
3220!^ & ubar(Iend+1,j,knew)
3221!^
3222 tl_du_flux(iend+1,j)=0.5_r8*on_u(iend+1,j)* &
3223 & ((dnew(iend+1,j)+ &
3224 & dnew(iend ,j))* &
3225 & tl_ubar(iend+1,j,knew)+ &
3226 & (tl_dnew(iend+1,j)+ &
3227 & tl_dnew(iend ,j))* &
3228 & ubar(iend+1,j,knew))- &
3229# ifdef TL_IOMS
3230 & 0.5_r8*on_u(iend+1,j)* &
3231 & (dnew(iend+1,j)+dnew(iend,j))* &
3232 & ubar(iend+1,j,knew)
3233# endif
3234 END DO
3235 DO j=jstrv,jend
3236!^ DV_flux(Iend+1,j)=0.5_r8*om_v(Iend+1,j)* &
3237!^ & (Dnew(Iend+1,j)+Dnew(Iend+1,j-1))* &
3238!^ & vbar(Iend+1,j,knew)
3239!^
3240 tl_dv_flux(iend+1,j)=0.5_r8*om_v(iend+1,j)* &
3241 & ((dnew(iend+1,j )+ &
3242 & dnew(iend+1,j-1))* &
3243 & tl_vbar(iend+1,j,knew)+ &
3244 & (tl_dnew(iend+1,j )+ &
3245 & tl_dnew(iend+1,j-1))* &
3246 & vbar(iend+1,j,knew))- &
3247# ifdef TL_IOMS
3248 & 0.5_r8*om_v(iend+1,j)* &
3249 & (dnew(iend+1,j)+dnew(iend+1,j-1))* &
3250 & vbar(iend+1,j,knew)
3251# endif
3252 END DO
3253 END IF
3254 END IF
3255 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3256 IF (domain(ng)%Southern_Edge(tile)) THEN
3257 DO i=istru,iend
3258!^ DU_flux(i,Jstr-1)=0.5_r8*on_u(i,Jstr-1)* &
3259!^ & (Dnew(i,Jstr-1)+Dnew(i-1,Jstr-1))* &
3260!^ & ubar(i,Jstr-1,knew)
3261!^
3262 tl_du_flux(i,jstr-1)=0.5_r8*on_u(i,jstr-1)* &
3263 & ((dnew(i ,jstr-1)+ &
3264 & dnew(i-1,jstr-1))* &
3265 & tl_ubar(i,jstr-1,knew)+ &
3266 & (tl_dnew(i ,jstr-1)+ &
3267 & tl_dnew(i-1,jstr-1))* &
3268 & ubar(i,jstr-1,knew))- &
3269# ifdef TL_IOMS
3270 & 0.5_r8*on_u(i,jstr-1)* &
3271 & (dnew(i,jstr-1)+dnew(i-1,jstr-1))* &
3272 & ubar(i,jstr-1,knew)
3273# endif
3274 END DO
3275 DO i=istrr,iendr
3276!^ DV_flux(i,JstrV-1)=0.5_r8*om_v(i,JstrV-1)* &
3277!^ & (Dnew(i,JstrV-1)+Dnew(i,JstrV-2))* &
3278!^ & vbar(i,JstrV-1,knew)
3279!^
3280 tl_dv_flux(i,jstrv-1)=0.5_r8*om_v(i,jstrv-1)* &
3281 & ((dnew(i,jstrv-1)+ &
3282 & dnew(i,jstrv-2))* &
3283 & tl_vbar(i,jstrv-1,knew)+ &
3284 & (tl_dnew(i,jstrv-1)+ &
3285 & tl_dnew(i,jstrv-2))* &
3286 & vbar(i,jstrv-1,knew))- &
3287# ifdef TL_IOMS
3288 & 0.5_r8*om_v(i,jstrv-1)* &
3289 & (dnew(i,jstrv-1)+dnew(i,jstrv-2))* &
3290 & vbar(i,jstrv-1,knew)
3291# endif
3292 END DO
3293 END IF
3294 END IF
3295 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3296 IF (domain(ng)%Northern_Edge(tile)) THEN
3297 DO i=istru,iend
3298!^ DU_flux(i,Jend+1)=0.5_r8*on_u(i,Jend+1)* &
3299!^ & (Dnew(i,Jend+1)+Dnew(i-1,Jend+1))* &
3300!^ & ubar(i,Jend+1,knew)
3301!^
3302 tl_du_flux(i,jend+1)=0.5_r8*on_u(i,jend+1)* &
3303 & ((dnew(i ,jend+1)+ &
3304 & dnew(i-1,jend+1))* &
3305 & tl_ubar(i,jend+1,knew)+ &
3306 & (tl_dnew(i ,jend+1)+ &
3307 & tl_dnew(i-1,jend+1))* &
3308 & ubar(i,jend+1,knew))- &
3309# ifdef TL_IOMS
3310 & 0.5_r8*on_u(i,jend+1)* &
3311 & (dnew(i,jend+1)+dnew(i-1,jend+1))* &
3312 & ubar(i,jend+1,knew)
3313# endif
3314 END DO
3315 DO i=istrr,iendr
3316!^ DV_flux(i,Jend+1)=0.5_r8*om_v(i,Jend+1)* &
3317!^ & (Dnew(i,Jend+1)+Dnew(i,Jend))* &
3318!^ & vbar(i,Jend+1,knew)
3319!^
3320 tl_dv_flux(i,jend+1)=0.5_r8*om_v(i,jend+1)* &
3321 & ((dnew(i,jend+1)+ &
3322 & dnew(i,jend ))* &
3323 & tl_vbar(i,jend+1,knew)+ &
3324 & (tl_dnew(i,jend+1)+ &
3325 & tl_dnew(i,jend ))* &
3326 & vbar(i,jend+1,knew))- &
3327# ifdef TL_IOMS
3328 & 0.5_r8*om_v(i,jend+1)* &
3329 & (dnew(i,jend+1)+dnew(i,jend))* &
3330 & vbar(i,jend+1,knew)
3331# endif
3332 END DO
3333 END IF
3334 END IF
3335#endif
3336!
3337! Apply momentum transport point sources (like river runoff), if any.
3338!
3339! Dsrc(is) = 0, flow across grid cell u-face (positive or negative)
3340! Dsrc(is) = 1, flow across grid cell v-face (positive or negative)
3341!
3342 IF (luvsrc(ng)) THEN
3343 DO is=1,nsrc(ng)
3344 i=sources(ng)%Isrc(is)
3345 j=sources(ng)%Jsrc(is)
3346 IF (((istrr.le.i).and.(i.le.iendr)).and. &
3347 & ((jstrr.le.j).and.(j.le.jendr))) THEN
3348 IF (int(sources(ng)%Dsrc(is)).eq.0) THEN
3349 cff=1.0_r8/(on_u(i,j)* &
3350 & 0.5_r8*(dnew(i-1,j)+dnew(i,j)))
3351 tl_cff=-cff*cff*on_u(i,j)* &
3352 & 0.5_r8*(tl_dnew(i-1,j)+tl_dnew(i ,j))+ &
3353#ifdef TL_IOMS
3354 & 2.0_r8*cff
3355#endif
3356!^ ubar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3357!^
3358 tl_ubar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3359 & sources(ng)%Qbar(is)*tl_cff- &
3360#ifdef TL_IOMS
3361 & sources(ng)%Qbar(is)*cff
3362#endif
3363#ifdef SOLVE3D
3364!^ DU_avg1(i,j)=SOURCES(ng)%Qbar(is)
3365!^
3366 tl_du_avg1(i,j)=sources(ng)%tl_Qbar(is)
3367#endif
3368#if defined NESTING && !defined SOLVE3D
3369!^ DU_flux(i,j)=SOURCES(ng)%Qbar(is)
3370!^
3371 tl_du_flux(i,j)=sources(ng)%tl_Qbar(is)
3372#endif
3373 ELSE IF (int(sources(ng)%Dsrc(is)).eq.1) THEN
3374 cff=1.0_r8/(om_v(i,j)* &
3375 & 0.5_r8*(dnew(i,j-1)+dnew(i,j)))
3376 tl_cff=-cff*cff*om_v(i,j)* &
3377 & 0.5_r8*(tl_dnew(i,j-1)+tl_dnew(i,j))+ &
3378#ifdef TL_IOMS
3379 & 2.0_r8*cff
3380#endif
3381!^ vbar(i,j,knew)=SOURCES(ng)%Qbar(is)*cff
3382!^
3383 tl_vbar(i,j,knew)=sources(ng)%tl_Qbar(is)*cff+ &
3384 & sources(ng)%Qbar(is)*tl_cff- &
3385#ifdef TL_IOMS
3386 & sources(ng)%Qbar(is)*cff
3387#endif
3388#ifdef SOLVE3D
3389!^ DV_avg1(i,j)=SOURCES(ng)%Qbar(is)
3390!^
3391 tl_dv_avg1(i,j)=sources(ng)%tl_Qbar(is)
3392#endif
3393#if defined NESTING && !defined SOLVE3D
3394!^ DV_flux(i,j)=SOURCES(ng)%Qbar(is)
3395!^
3396 tl_dv_flux(i,j)=sources(ng)%tl_Qbar(is)
3397#endif
3398 END IF
3399 END IF
3400 END DO
3401 END IF
3402
3403#ifdef SOLVE3D
3404!
3405!-----------------------------------------------------------------------
3406! Finalize computation of barotropic mode averages.
3407!-----------------------------------------------------------------------
3408!
3409! This procedure starts with filling in boundary rows of total depths
3410! at the new time step, which is needed to be done only during the
3411! last barotropic time step, Normally, the computation of averages
3412! occurs at the beginning of the next predictor step because "DUon"
3413! and "DVom" are being computed anyway. Strictly speaking, the filling
3414! the boundaries are necessary only in the case of open boundaries,
3415! otherwise, the associated fluxes are all zeros.
3416!
3417 IF ((iif(ng).eq.nfast(ng)).and.(knew.lt.3)) THEN
3418 IF (.not.(compositegrid(iwest,ng).or.ewperiodic(ng))) THEN
3419 IF (domain(ng)%Western_Edge(tile)) THEN
3420 DO j=jstr-1,jendr
3421!^ Dnew(Istr-1,j)=h(Istr-1,j)+zeta_new(Istr-1,j)
3422!^
3423 tl_dnew(istr-1,j)=tl_h(istr-1,j)+tl_zeta_new(istr-1,j)
3424 END DO
3425 END IF
3426 END IF
3427 IF (.not.(compositegrid(ieast,ng).or.ewperiodic(ng))) THEN
3428 IF (domain(ng)%Eastern_Edge(tile)) THEN
3429 DO j=jstr-1,jendr
3430!^ Dnew(Iend+1,j)=h(Iend+1,j)+zeta_new(Iend+1,j)
3431!^
3432 tl_dnew(iend+1,j)=tl_h(iend+1,j)+tl_zeta_new(iend+1,j)
3433 END DO
3434 END IF
3435 END IF
3436 IF (.not.(compositegrid(isouth,ng).or.nsperiodic(ng))) THEN
3437 IF (domain(ng)%Southern_Edge(tile)) THEN
3438 DO i=istr-1,iendr
3439!^ Dnew(i,Jstr-1)=h(i,Jstr-1)+zeta_new(i,Jstr-1)
3440!^
3441 tl_dnew(i,jstr-1)=tl_h(i,jstr-1)+tl_zeta_new(i,jstr-1)
3442 END DO
3443 END IF
3444 END IF
3445 IF (.not.(compositegrid(inorth,ng).or.nsperiodic(ng))) THEN
3446 IF (domain(ng)%Northern_Edge(tile)) THEN
3447 DO i=istr-1,iendr
3448!^ Dnew(i,Jend+1)=h(i,Jend+1)+zeta_new(i,Jend+1)
3449!^
3450 tl_dnew(i,jend+1)=tl_h(i,jend+1)+tl_zeta_new(i,jend+1)
3451 END DO
3452 END IF
3453 END IF
3454!
3455! At the end of the last 2D time step replace the new free-surface
3456! zeta(:,:,knew) with it fast time-averaged value, Zt_avg1. Recall
3457! this is state variable is the one that communicates with the 3D
3458! kernel. Then, compute time-dependent depths.
3459!
3460 cff=weight(1,iif(ng),ng)
3461 cff1=0.5*cff
3462 DO j=jstrr,jendr
3463 DO i=istrr,iendr
3464!^ Zt_avg1(i,j)=Zt_avg1(i,j)+ &
3465!^ & cff*zeta(i,j,knew)
3466!^
3467 tl_zt_avg1(i,j)=tl_zt_avg1(i,j)+ &
3468 & cff*tl_zeta(i,j,knew)
3469 IF (i.ge.istr) THEN
3470!^ DU_avg1(i,j)=DU_avg1(i,j)+ &
3471!^ & cff1*on_u(i,j)* &
3472!^ & (Dnew(i,j)+Dnew(i-1,j))*ubar(i,j,knew)
3473!^
3474 tl_du_avg1(i,j)=tl_du_avg1(i,j)+ &
3475 & cff1*on_u(i,j)* &
3476 & ((dnew(i,j)+dnew(i-1,j))* &
3477 & tl_ubar(i,j,knew)+ &
3478 & (tl_dnew(i,j)+tl_dnew(i-1,j))* &
3479 & ubar(i,j,knew))- &
3480# ifdef TL_IOMS
3481 & cff1*on_u(i,j)* &
3482 & ((dnew(i,j)+dnew(i-1,j))* &
3483 & ubar(i,j,knew)
3484# endif
3485 END IF
3486 IF (j.ge.jstr) THEN
3487!^ DV_avg1(i,j)=DV_avg1(i,j)+ &
3488!^ & cff1*om_v(i,j)* &
3489!^ & (Dnew(i,j)+Dnew(i,j-1))*vbar(i,j,knew)
3490!^
3491 tl_dv_avg1(i,j)=tl_dv_avg1(i,j)+ &
3492 & cff1*om_v(i,j)* &
3493 & ((dnew(i,j)+dnew(i,j-1))* &
3494 & tl_vbar(i,j,knew)+ &
3495 & (tl_dnew(i,j)+tl_dnew(i,j-1))* &
3496 & vbar(i,j,knew))- &
3497# ifdef TL_IOMS
3498 & cff1*om_v(i,j)* &
3499 & ((dnew(i,j)+dnew(i,j-1))* &
3500 & vbar(i,j,knew)
3501# endif
3502 END IF
3503!^ zeta(i,j,knew)=Zt_avg1(i,j)
3504!^
3505 tl_zeta(i,j,knew)=tl_zt_avg1(i,j)
3506 END DO
3507 END DO
3508!^ CALL set_depth (ng, tile, iNLM)
3509!^
3510 CALL rp_set_depth (ng, tile, irpm)
3511
3512# ifdef NESTING
3513!
3514! After all fast time steps are completed, apply boundary conditions
3515! to time averaged fields.
3516!
3517! In nesting applications with refinement grids, we need to exchange
3518! the DU_avg2 and DV_avg2 fluxes boundary information for the case
3519! that a contact point is at a tile partition. Notice that in such
3520! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3521!
3522 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3523!^ CALL exchange_r2d_tile (ng, tile, &
3524!^ & LBi, UBi, LBj, UBj, &
3525!^ & Zt_avg1)
3526!^
3527 CALL exchange_r2d_tile (ng, tile, &
3528 & lbi, ubi, lbj, ubj, &
3529 & tl_zt_avg1)
3530!^ CALL exchange_u2d_tile (ng, tile, &
3531!^ & LBi, UBi, LBj, UBj, &
3532!^ & DU_avg1)
3533!^
3534 CALL exchange_u2d_tile (ng, tile, &
3535 & lbi, ubi, lbj, ubj, &
3536 & tl_du_avg1)
3537!^ CALL exchange_v2d_tile (ng, tile, &
3538!^ & LBi, UBi, LBj, UBj, &
3539!^ & DV_avg1)
3540!^
3541 CALL exchange_v2d_tile (ng, tile, &
3542 & lbi, ubi, lbj, ubj, &
3543 & tl_dv_avg1)
3544!^ CALL exchange_u2d_tile (ng, tile, &
3545!^ & LBi, UBi, LBj, UBj, &
3546!^ & DU_avg2)
3547!^
3548 CALL exchange_u2d_tile (ng, tile, &
3549 & lbi, ubi, lbj, ubj, &
3550 & tl_du_avg2)
3551!^ CALL exchange_v2d_tile (ng, tile, &
3552!^ & LBi, UBi, LBj, UBj, &
3553!^ & DV_avg2)
3554!^
3555 CALL exchange_v2d_tile (ng, tile, &
3556 & lbi, ubi, lbj, ubj, &
3557 & tl_dv_avg2)
3558 END IF
3559
3560# ifdef DISTRIBUTE
3561!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3562!^ & LBi, UBi, LBj, UBj, &
3563!^ & NghostPoints, &
3564!^ & EWperiodic(ng), NSperiodic(ng), &
3565!^ & Zt_avg1, DU_avg1, DV_avg1)
3566!^
3567 CALL mp_exchange2d (ng, tile, irpm, 3, &
3568 & lbi, ubi, lbj, ubj, &
3569 & nghostpoints, &
3570 & ewperiodic(ng), nsperiodic(ng), &
3571 & tl_zt_avg1, tl_du_avg1, tl_dv_avg1)
3572!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3573!^ & LBi, UBi, LBj, UBj, &
3574!^ & NghostPoints, &
3575!^ & EWperiodic(ng), NSperiodic(ng), &
3576!^ & DU_avg2, DV_avg2)
3577!^
3578 CALL mp_exchange2d (ng, tile, irpm, 2, &
3579 & lbi, ubi, lbj, ubj, &
3580 & nghostpoints, &
3581 & ewperiodic(ng), nsperiodic(ng), &
3582 & tl_du_avg2, tl_dv_avg2)
3583# endif
3584# endif
3585 END IF
3586#endif
3587#if defined NESTING && !defined SOLVE3D
3588!
3589! In nesting applications with refinement grids, we need to exchange
3590! the DU_flux and DV_flux fluxes boundary information for the case
3591! that a contact point is at a tile partition. Notice that in such
3592! cases, we need i+1 and j+1 values for spatial/temporal interpolation.
3593!
3594 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3595!^ CALL exchange_u2d_tile (ng, tile, &
3596!^ & LBi, UBi, LBj, UBj, &
3597!^ & DU_flux)
3598!^
3599 CALL exchange_u2d_tile (ng, tile, &
3600 & lbi, ubi, lbj, ubj, &
3601 & tl_du_flux)
3602!^ CALL exchange_v2d_tile (ng, tile, &
3603!^ & LBi, UBi, LBj, UBj, &
3604!^ & DV_flux)
3605!^
3606 CALL exchange_v2d_tile (ng, tile, &
3607 & lbi, ubi, lbj, ubj, &
3608 & tl_dv_flux)
3609 END IF
3610
3611# ifdef DISTRIBUTE
3612!
3613!^ CALL mp_exchange2d (ng, tile, iNLM, 2, &
3614!^ & LBi, UBi, LBj, UBj, &
3615!^ & NghostPoints, &
3616!^ & EWperiodic(ng), NSperiodic(ng), &
3617!^ & DU_flux, DV_flux)
3618!^
3619 CALL mp_exchange2d (ng, tile, irpm, 2, &
3620 & lbi, ubi, lbj, ubj, &
3621 & nghostpoints, &
3622 & ewperiodic(ng), nsperiodic(ng), &
3623 & tl_du_flux, tl_dv_flux)
3624# endif
3625#endif
3626!
3627! Deallocate local new free-surface.
3628!
3629 deallocate ( tl_zeta_new )
3630
3631#ifdef WET_DRY_NOT_YET
3632!
3633!-----------------------------------------------------------------------
3634! Compute new wet/dry masks.
3635!-----------------------------------------------------------------------
3636!
3637!^ CALL wetdry_tile (ng, tile, &
3638!^ & LBi, UBi, LBj, UBj, &
3639!^ & IminS, ImaxS, JminS, JmaxS, &
3640# ifdef MASKING
3641!^ & pmask, rmask, umask, vmask, &
3642# endif
3643!^ & h, zeta(:,:,knew), &
3644# ifdef SOLVE3D
3645!^ & DU_avg1, DV_avg1, &
3646!^ & rmask_wet_avg, &
3647# endif
3648!^ & pmask_wet, pmask_full, &
3649!^ & rmask_wet, rmask_full, &
3650!^ & umask_wet, umask_full, &
3651!^ & vmask_wet, vmask_full)
3652!^
3653!^ HGA: Need the TLM code here.
3654!^
3655#endif
3656!
3657!-----------------------------------------------------------------------
3658! Exchange boundary information.
3659!-----------------------------------------------------------------------
3660!
3661 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
3662!^ CALL exchange_r2d_tile (ng, tile, &
3663!^ & LBi, UBi, LBj, UBj, &
3664!^ & zeta(:,:,knew))
3665!^
3666 CALL exchange_r2d_tile (ng, tile, &
3667 & lbi, ubi, lbj, ubj, &
3668 & tl_zeta(:,:,knew))
3669!^ CALL exchange_u2d_tile (ng, tile, &
3670!^ & LBi, UBi, LBj, UBj, &
3671!^ & ubar(:,:,knew))
3672!^
3673 CALL exchange_u2d_tile (ng, tile, &
3674 & lbi, ubi, lbj, ubj, &
3675 & tl_ubar(:,:,knew))
3676!^ CALL exchange_v2d_tile (ng, tile, &
3677!^ & LBi, UBi, LBj, UBj, &
3678!^ & vbar(:,:,knew))
3679!^
3680 CALL exchange_v2d_tile (ng, tile, &
3681 & lbi, ubi, lbj, ubj, &
3682 & tl_vbar(:,:,knew))
3683 END IF
3684
3685#ifdef DISTRIBUTE
3686!
3687!^ CALL mp_exchange2d (ng, tile, iNLM, 3, &
3688!^ & LBi, UBi, LBj, UBj, &
3689!^ & NghostPoints, &
3690!^ & EWperiodic(ng), NSperiodic(ng), &
3691!^ & zeta(:,:,knew), &
3692!^ & ubar(:,:,knew), &
3693!^ & vbar(:,:,knew))
3694!^
3695 CALL mp_exchange2d (ng, tile, irpm, 3, &
3696 & lbi, ubi, lbj, ubj, &
3697 & nghostpoints, &
3698 & ewperiodic(ng), nsperiodic(ng), &
3699 & tl_zeta(:,:,knew), &
3700 & tl_ubar(:,:,knew), &
3701 & tl_vbar(:,:,knew))
3702#endif
3703!
3704 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_param::irpm, mod_scalars::isouth, mod_scalars::iwest, mod_scalars::luvsrc, mod_scalars::lwsrc, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_scalars::nfast, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_sources::nsrc, obc_volcons_mod::obc_flux_tile(), mod_scalars::predictor_2d_step, mod_scalars::rho0, rp_obc_volcons_mod::rp_obc_flux_tile(), rp_set_depth_mod::rp_set_depth(), rp_obc_volcons_mod::rp_set_duv_bc_tile(), rp_u2dbc_mod::rp_u2dbc_tile(), rp_v2dbc_mod::rp_v2dbc_tile(), obc_volcons_mod::set_duv_bc_tile(), mod_sources::sources, mod_scalars::tl_m2diff, mod_scalars::volcons, and mod_scalars::weight.

Here is the call graph for this function:

◆ rp_step2d_tile() [2/3]

subroutine rp_step2d_mod::rp_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_sustr,
real(r8), dimension(lbi:ubi,lbj:ubj), intent(in) tl_svstr,
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(inout) rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rubar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) tl_rvbar,
real(r8), dimension(lbi:ubi,lbj:ubj,2), intent(inout) 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 184 of file rp_step2d_LF_AM3.h.

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

Here is the call graph for this function:

◆ rp_step2d_tile() [3/3]

subroutine rp_step2d_mod::rp_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 206 of file rp_step2d_FB.h.

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

Referenced by rp_step2d().

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