FV3 Bundle
sw_core_tlm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20  module sw_core_tlm_mod
21 
22  use fv_mp_nlm_mod, only: ng
23  use tp_core_tlm_mod, only: fv_tp_2d, pert_ppm, copy_corners
24  use tp_core_tlm_mod, only: fv_tp_2d_tlm, copy_corners_tlm
25  use fv_mp_nlm_mod, only: xdir, ydir
26  use fv_mp_nlm_mod, only: fill_corners
27  use fv_mp_tlm_mod, only: fill_corners_tlm
28  use fv_arrays_nlm_mod, only: fv_grid_type, fv_grid_bounds_type, fv_flags_type, r_grid
29  use a2b_edge_tlm_mod, only: a2b_ord4
30  use a2b_edge_tlm_mod, only: a2b_ord4_tlm
31  use fv_arrays_tlmadm_mod,only: fpp
32 
33 #ifdef SW_DYNAMICS
34  use test_cases_nlm_mod, only: test_case
35 #endif
36 
37  implicit none
38 
39  real, parameter:: r3 = 1./3.
40  real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28.
41  real, parameter:: s11=11./14., s13=-13./14., s14=4./7., s15=3./14.
42  real, parameter:: near_zero = 1.e-9 ! for KE limiter
43 #ifdef OVERLOAD_R4
44  real, parameter:: big_number = 1.e8
45 #else
46  real, parameter:: big_number = 1.e30
47 #endif
48 !----------------------
49 ! PPM volume mean form:
50 !----------------------
51  real, parameter:: p1 = 7./12. ! 0.58333333
52  real, parameter:: p2 = -1./12.
53 !----------------------------
54 ! 4-pt Lagrange interpolation
55 !----------------------------
56  real, parameter:: a1 = 0.5625
57  real, parameter:: a2 = -0.0625
58 !----------------------------------------------
59 ! volume-conserving cubic with 2nd drv=0 at end point:
60  real, parameter:: c1 = -2./14.
61  real, parameter:: c2 = 11./14.
62  real, parameter:: c3 = 5./14.
63 ! 3-pt off-center intp formular:
64 ! real, parameter:: c1 = -0.125
65 ! real, parameter:: c2 = 0.75
66 ! real, parameter:: c3 = 0.375
67 !----------------------------------------------
68 ! scheme 2.1: perturbation form
69  real, parameter:: b1 = 1./30.
70  real, parameter:: b2 = -13./60.
71  real, parameter:: b3 = -13./60.
72  real, parameter:: b4 = 0.45
73  real, parameter:: b5 = -0.05
74 
75  private
76  public :: c_sw, d_sw, fill_4corners, del6_vt_flux, divergence_corner, divergence_corner_nest
77  public :: d2a2c_vect
78  public :: c_sw_tlm, d_sw_tlm, fill_4corners_tlm, del6_vt_flux_tlm, divergence_corner_tlm, divergence_corner_nest_tlm
79  public :: d2a2c_vect_tlm
80 
81 CONTAINS
82 ! Differentiation of c_sw in forward (tangent) mode:
83 ! variations of useful results: w delp ua uc ptc ut delpc va
84 ! vc vt divg_d wc pt
85 ! with respect to varying inputs: u v w delp ua uc ptc ut delpc
86 ! va vc vt divg_d wc pt
87  SUBROUTINE c_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, &
88 & pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, &
89 & va, va_tl, wc, wc_tl, ut, ut_tl, vt, vt_tl, divg_d, divg_d_tl, nord&
90 & , dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
91  IMPLICIT NONE
92  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
93  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
94 & , vc
95  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
96 & u_tl, vc_tl
97  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
98 & , uc
99  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
100 & v_tl, uc_tl
101  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
102 & , pt, ua, va, ut, vt
103  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
104 & delp_tl, pt_tl, ua_tl, va_tl, ut_tl, vt_tl
105  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
106  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w_tl
107  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
108 & , ptc, wc
109  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: &
110 & delpc_tl, ptc_tl, wc_tl
111  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
112 & divg_d
113  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
114 & divg_d_tl
115  INTEGER, INTENT(IN) :: nord
116  REAL, INTENT(IN) :: dt2
117  LOGICAL, INTENT(IN) :: hydrostatic
118  LOGICAL, INTENT(IN) :: dord4
119  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
120  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
121 ! Local:
122  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
123  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort, ke
124  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort_tl, ke_tl
125  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx, fx1, fx2
126  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx_tl, fx1_tl, &
127 & fx2_tl
128  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy, fy1, fy2
129  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy_tl, fy1_tl, &
130 & fy2_tl
131  REAL :: dt4
132  INTEGER :: i, j, is2, ie1
133  INTEGER :: iep1, jep1
134  INTEGER :: is, ie, js, je
135  INTEGER :: isd, ied, jsd, jed
136  INTEGER :: npx, npy
137  LOGICAL :: nested
138  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
139  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
140  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
141  REAL, DIMENSION(:, :), POINTER :: dx, dy, dxc, dyc
142  is = bd%is
143  ie = bd%ie
144  js = bd%js
145  je = bd%je
146  isd = bd%isd
147  ied = bd%ied
148  jsd = bd%jsd
149  jed = bd%jed
150  npx = flagstruct%npx
151  npy = flagstruct%npy
152  nested = gridstruct%nested
153  sin_sg => gridstruct%sin_sg
154  cos_sg => gridstruct%cos_sg
155  cosa_u => gridstruct%cosa_u
156  cosa_v => gridstruct%cosa_v
157  sina_u => gridstruct%sina_u
158  sina_v => gridstruct%sina_v
159  dx => gridstruct%dx
160  dy => gridstruct%dy
161  dxc => gridstruct%dxc
162  dyc => gridstruct%dyc
163  sw_corner = gridstruct%sw_corner
164  se_corner = gridstruct%se_corner
165  nw_corner = gridstruct%nw_corner
166  ne_corner = gridstruct%ne_corner
167  iep1 = ie + 1
168  jep1 = je + 1
169  CALL d2a2c_vect_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, va_tl, uc, &
170 & uc_tl, vc, vc_tl, ut, ut_tl, vt, vt_tl, dord4, &
171 & gridstruct, bd, npx, npy, nested, flagstruct%grid_type&
172 & )
173  IF (nord .GT. 0) THEN
174  IF (nested) THEN
175  CALL divergence_corner_nest_tlm(u, u_tl, v, v_tl, ua, ua_tl, va&
176 & , va_tl, divg_d, divg_d_tl, gridstruct&
177 & , flagstruct, bd)
178  ELSE
179  CALL divergence_corner_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, &
180 & va_tl, divg_d, divg_d_tl, gridstruct, &
181 & flagstruct, bd)
182  END IF
183  END IF
184  DO j=js-1,jep1
185  DO i=is-1,iep1+1
186  IF (ut(i, j) .GT. 0.) THEN
187  ut_tl(i, j) = dt2*dy(i, j)*sin_sg(i-1, j, 3)*ut_tl(i, j)
188  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i-1, j, 3)
189  ELSE
190  ut_tl(i, j) = dt2*dy(i, j)*sin_sg(i, j, 1)*ut_tl(i, j)
191  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i, j, 1)
192  END IF
193  END DO
194  END DO
195  DO j=js-1,je+2
196  DO i=is-1,iep1
197  IF (vt(i, j) .GT. 0.) THEN
198  vt_tl(i, j) = dt2*dx(i, j)*sin_sg(i, j-1, 4)*vt_tl(i, j)
199  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j-1, 4)
200  ELSE
201  vt_tl(i, j) = dt2*dx(i, j)*sin_sg(i, j, 2)*vt_tl(i, j)
202  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j, 2)
203  END IF
204  END DO
205  END DO
206 !----------------
207 ! Transport delp:
208 !----------------
209 ! Xdir:
210  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
211 & fill2_4corners_tlm(delp, delp_tl, pt, pt_tl, 1, bd, npx, npy, &
212 & sw_corner, se_corner, ne_corner, nw_corner)
213  IF (hydrostatic) THEN
214  fx_tl = 0.0
215  fx1_tl = 0.0
216  DO j=js-1,jep1
217  DO i=is-1,ie+2
218  IF (ut(i, j) .GT. 0.) THEN
219  fx1_tl(i, j) = delp_tl(i-1, j)
220  fx1(i, j) = delp(i-1, j)
221  fx_tl(i, j) = pt_tl(i-1, j)
222  fx(i, j) = pt(i-1, j)
223  ELSE
224  fx1_tl(i, j) = delp_tl(i, j)
225  fx1(i, j) = delp(i, j)
226  fx_tl(i, j) = pt_tl(i, j)
227  fx(i, j) = pt(i, j)
228  END IF
229  fx1_tl(i, j) = ut_tl(i, j)*fx1(i, j) + ut(i, j)*fx1_tl(i, j)
230  fx1(i, j) = ut(i, j)*fx1(i, j)
231  fx_tl(i, j) = fx1_tl(i, j)*fx(i, j) + fx1(i, j)*fx_tl(i, j)
232  fx(i, j) = fx1(i, j)*fx(i, j)
233  END DO
234  END DO
235  fx2_tl = 0.0
236  ELSE
237  IF (flagstruct%grid_type .LT. 3) THEN
238  CALL fill_4corners_tlm(w, w_tl, 1, bd, npx, npy, sw_corner, &
239 & se_corner, ne_corner, nw_corner)
240  fx_tl = 0.0
241  fx1_tl = 0.0
242  fx2_tl = 0.0
243  ELSE
244  fx_tl = 0.0
245  fx1_tl = 0.0
246  fx2_tl = 0.0
247  END IF
248  DO j=js-1,je+1
249  DO i=is-1,ie+2
250  IF (ut(i, j) .GT. 0.) THEN
251  fx1_tl(i, j) = delp_tl(i-1, j)
252  fx1(i, j) = delp(i-1, j)
253  fx_tl(i, j) = pt_tl(i-1, j)
254  fx(i, j) = pt(i-1, j)
255  fx2_tl(i, j) = w_tl(i-1, j)
256  fx2(i, j) = w(i-1, j)
257  ELSE
258  fx1_tl(i, j) = delp_tl(i, j)
259  fx1(i, j) = delp(i, j)
260  fx_tl(i, j) = pt_tl(i, j)
261  fx(i, j) = pt(i, j)
262  fx2_tl(i, j) = w_tl(i, j)
263  fx2(i, j) = w(i, j)
264  END IF
265  fx1_tl(i, j) = ut_tl(i, j)*fx1(i, j) + ut(i, j)*fx1_tl(i, j)
266  fx1(i, j) = ut(i, j)*fx1(i, j)
267  fx_tl(i, j) = fx1_tl(i, j)*fx(i, j) + fx1(i, j)*fx_tl(i, j)
268  fx(i, j) = fx1(i, j)*fx(i, j)
269  fx2_tl(i, j) = fx1_tl(i, j)*fx2(i, j) + fx1(i, j)*fx2_tl(i, j)
270  fx2(i, j) = fx1(i, j)*fx2(i, j)
271  END DO
272  END DO
273  END IF
274 ! Ydir:
275  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
276 & fill2_4corners_tlm(delp, delp_tl, pt, pt_tl, 2, bd, npx, npy, &
277 & sw_corner, se_corner, ne_corner, nw_corner)
278  IF (hydrostatic) THEN
279  fy1_tl = 0.0
280  fy_tl = 0.0
281  DO j=js-1,jep1+1
282  DO i=is-1,iep1
283  IF (vt(i, j) .GT. 0.) THEN
284  fy1_tl(i, j) = delp_tl(i, j-1)
285  fy1(i, j) = delp(i, j-1)
286  fy_tl(i, j) = pt_tl(i, j-1)
287  fy(i, j) = pt(i, j-1)
288  ELSE
289  fy1_tl(i, j) = delp_tl(i, j)
290  fy1(i, j) = delp(i, j)
291  fy_tl(i, j) = pt_tl(i, j)
292  fy(i, j) = pt(i, j)
293  END IF
294  fy1_tl(i, j) = vt_tl(i, j)*fy1(i, j) + vt(i, j)*fy1_tl(i, j)
295  fy1(i, j) = vt(i, j)*fy1(i, j)
296  fy_tl(i, j) = fy1_tl(i, j)*fy(i, j) + fy1(i, j)*fy_tl(i, j)
297  fy(i, j) = fy1(i, j)*fy(i, j)
298  END DO
299  END DO
300  DO j=js-1,jep1
301  DO i=is-1,iep1
302  delpc_tl(i, j) = delp_tl(i, j) + gridstruct%rarea(i, j)*(&
303 & fx1_tl(i, j)-fx1_tl(i+1, j)+fy1_tl(i, j)-fy1_tl(i, j+1))
304  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
305 & fy1(i, j+1)))*gridstruct%rarea(i, j)
306  ptc_tl(i, j) = ((pt_tl(i, j)*delp(i, j)+pt(i, j)*delp_tl(i, j)&
307 & +gridstruct%rarea(i, j)*(fx_tl(i, j)-fx_tl(i+1, j)+fy_tl(i, &
308 & j)-fy_tl(i, j+1)))*delpc(i, j)-(pt(i, j)*delp(i, j)+(fx(i, j&
309 & )-fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*gridstruct%rarea(i, j))*&
310 & delpc_tl(i, j))/delpc(i, j)**2
311  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
312 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
313  END DO
314  END DO
315  ELSE
316  IF (flagstruct%grid_type .LT. 3) THEN
317  CALL fill_4corners_tlm(w, w_tl, 2, bd, npx, npy, sw_corner, &
318 & se_corner, ne_corner, nw_corner)
319  fy1_tl = 0.0
320  fy2_tl = 0.0
321  fy_tl = 0.0
322  ELSE
323  fy1_tl = 0.0
324  fy2_tl = 0.0
325  fy_tl = 0.0
326  END IF
327  DO j=js-1,je+2
328  DO i=is-1,ie+1
329  IF (vt(i, j) .GT. 0.) THEN
330  fy1_tl(i, j) = delp_tl(i, j-1)
331  fy1(i, j) = delp(i, j-1)
332  fy_tl(i, j) = pt_tl(i, j-1)
333  fy(i, j) = pt(i, j-1)
334  fy2_tl(i, j) = w_tl(i, j-1)
335  fy2(i, j) = w(i, j-1)
336  ELSE
337  fy1_tl(i, j) = delp_tl(i, j)
338  fy1(i, j) = delp(i, j)
339  fy_tl(i, j) = pt_tl(i, j)
340  fy(i, j) = pt(i, j)
341  fy2_tl(i, j) = w_tl(i, j)
342  fy2(i, j) = w(i, j)
343  END IF
344  fy1_tl(i, j) = vt_tl(i, j)*fy1(i, j) + vt(i, j)*fy1_tl(i, j)
345  fy1(i, j) = vt(i, j)*fy1(i, j)
346  fy_tl(i, j) = fy1_tl(i, j)*fy(i, j) + fy1(i, j)*fy_tl(i, j)
347  fy(i, j) = fy1(i, j)*fy(i, j)
348  fy2_tl(i, j) = fy1_tl(i, j)*fy2(i, j) + fy1(i, j)*fy2_tl(i, j)
349  fy2(i, j) = fy1(i, j)*fy2(i, j)
350  END DO
351  END DO
352  DO j=js-1,je+1
353  DO i=is-1,ie+1
354  delpc_tl(i, j) = delp_tl(i, j) + gridstruct%rarea(i, j)*(&
355 & fx1_tl(i, j)-fx1_tl(i+1, j)+fy1_tl(i, j)-fy1_tl(i, j+1))
356  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
357 & fy1(i, j+1)))*gridstruct%rarea(i, j)
358  ptc_tl(i, j) = ((pt_tl(i, j)*delp(i, j)+pt(i, j)*delp_tl(i, j)&
359 & +gridstruct%rarea(i, j)*(fx_tl(i, j)-fx_tl(i+1, j)+fy_tl(i, &
360 & j)-fy_tl(i, j+1)))*delpc(i, j)-(pt(i, j)*delp(i, j)+(fx(i, j&
361 & )-fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*gridstruct%rarea(i, j))*&
362 & delpc_tl(i, j))/delpc(i, j)**2
363  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
364 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
365  wc_tl(i, j) = ((w_tl(i, j)*delp(i, j)+w(i, j)*delp_tl(i, j)+&
366 & gridstruct%rarea(i, j)*(fx2_tl(i, j)-fx2_tl(i+1, j)+fy2_tl(i&
367 & , j)-fy2_tl(i, j+1)))*delpc(i, j)-(w(i, j)*delp(i, j)+(fx2(i&
368 & , j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*gridstruct%rarea(i&
369 & , j))*delpc_tl(i, j))/delpc(i, j)**2
370  wc(i, j) = (w(i, j)*delp(i, j)+(fx2(i, j)-fx2(i+1, j)+(fy2(i, &
371 & j)-fy2(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
372  END DO
373  END DO
374  END IF
375 !------------
376 ! Compute KE:
377 !------------
378 !Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the tru
379 !e coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa.
380 !Use the alpha for the cell KE is being computed in.
381 !!! TO DO:
382 !!! Need separate versions for nesting/single-tile
383 !!! and for cubed-sphere
384  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
385  ke_tl = 0.0
386  DO j=js-1,jep1
387  DO i=is-1,iep1
388  IF (ua(i, j) .GT. 0.) THEN
389  ke_tl(i, j) = uc_tl(i, j)
390  ke(i, j) = uc(i, j)
391  ELSE
392  ke_tl(i, j) = uc_tl(i+1, j)
393  ke(i, j) = uc(i+1, j)
394  END IF
395  END DO
396  END DO
397  vort_tl = 0.0
398  DO j=js-1,jep1
399  DO i=is-1,iep1
400  IF (va(i, j) .GT. 0.) THEN
401  vort_tl(i, j) = vc_tl(i, j)
402  vort(i, j) = vc(i, j)
403  ELSE
404  vort_tl(i, j) = vc_tl(i, j+1)
405  vort(i, j) = vc(i, j+1)
406  END IF
407  END DO
408  END DO
409  ELSE
410  ke_tl = 0.0
411  DO j=js-1,jep1
412  DO i=is-1,iep1
413  IF (ua(i, j) .GT. 0.) THEN
414  IF (i .EQ. 1) THEN
415  ke_tl(1, j) = sin_sg(1, j, 1)*uc_tl(1, j) + cos_sg(1, j, 1&
416 & )*v_tl(1, j)
417  ke(1, j) = uc(1, j)*sin_sg(1, j, 1) + v(1, j)*cos_sg(1, j&
418 & , 1)
419  ELSE IF (i .EQ. npx) THEN
420  ke_tl(i, j) = sin_sg(npx, j, 1)*uc_tl(npx, j) + cos_sg(npx&
421 & , j, 1)*v_tl(npx, j)
422  ke(i, j) = uc(npx, j)*sin_sg(npx, j, 1) + v(npx, j)*cos_sg&
423 & (npx, j, 1)
424  ELSE
425  ke_tl(i, j) = uc_tl(i, j)
426  ke(i, j) = uc(i, j)
427  END IF
428  ELSE IF (i .EQ. 0) THEN
429  ke_tl(0, j) = sin_sg(0, j, 3)*uc_tl(1, j) + cos_sg(0, j, 3)*&
430 & v_tl(1, j)
431  ke(0, j) = uc(1, j)*sin_sg(0, j, 3) + v(1, j)*cos_sg(0, j, 3&
432 & )
433  ELSE IF (i .EQ. npx - 1) THEN
434  ke_tl(i, j) = sin_sg(npx-1, j, 3)*uc_tl(npx, j) + cos_sg(npx&
435 & -1, j, 3)*v_tl(npx, j)
436  ke(i, j) = uc(npx, j)*sin_sg(npx-1, j, 3) + v(npx, j)*cos_sg&
437 & (npx-1, j, 3)
438  ELSE
439  ke_tl(i, j) = uc_tl(i+1, j)
440  ke(i, j) = uc(i+1, j)
441  END IF
442  END DO
443  END DO
444  vort_tl = 0.0
445  DO j=js-1,jep1
446  DO i=is-1,iep1
447  IF (va(i, j) .GT. 0.) THEN
448  IF (j .EQ. 1) THEN
449  vort_tl(i, 1) = sin_sg(i, 1, 2)*vc_tl(i, 1) + cos_sg(i, 1&
450 & , 2)*u_tl(i, 1)
451  vort(i, 1) = vc(i, 1)*sin_sg(i, 1, 2) + u(i, 1)*cos_sg(i, &
452 & 1, 2)
453  ELSE IF (j .EQ. npy) THEN
454  vort_tl(i, j) = sin_sg(i, npy, 2)*vc_tl(i, npy) + cos_sg(i&
455 & , npy, 2)*u_tl(i, npy)
456  vort(i, j) = vc(i, npy)*sin_sg(i, npy, 2) + u(i, npy)*&
457 & cos_sg(i, npy, 2)
458  ELSE
459  vort_tl(i, j) = vc_tl(i, j)
460  vort(i, j) = vc(i, j)
461  END IF
462  ELSE IF (j .EQ. 0) THEN
463  vort_tl(i, 0) = sin_sg(i, 0, 4)*vc_tl(i, 1) + cos_sg(i, 0, 4&
464 & )*u_tl(i, 1)
465  vort(i, 0) = vc(i, 1)*sin_sg(i, 0, 4) + u(i, 1)*cos_sg(i, 0&
466 & , 4)
467  ELSE IF (j .EQ. npy - 1) THEN
468  vort_tl(i, j) = sin_sg(i, npy-1, 4)*vc_tl(i, npy) + cos_sg(i&
469 & , npy-1, 4)*u_tl(i, npy)
470  vort(i, j) = vc(i, npy)*sin_sg(i, npy-1, 4) + u(i, npy)*&
471 & cos_sg(i, npy-1, 4)
472  ELSE
473  vort_tl(i, j) = vc_tl(i, j+1)
474  vort(i, j) = vc(i, j+1)
475  END IF
476  END DO
477  END DO
478  END IF
479  dt4 = 0.5*dt2
480  DO j=js-1,jep1
481  DO i=is-1,iep1
482  ke_tl(i, j) = dt4*(ua_tl(i, j)*ke(i, j)+ua(i, j)*ke_tl(i, j)+&
483 & va_tl(i, j)*vort(i, j)+va(i, j)*vort_tl(i, j))
484  ke(i, j) = dt4*(ua(i, j)*ke(i, j)+va(i, j)*vort(i, j))
485  END DO
486  END DO
487 !------------------------------
488 ! Compute circulation on C grid
489 !------------------------------
490 ! To consider using true co-variant winds at face edges?
491  DO j=js-1,je+1
492  DO i=is,ie+1
493  fx_tl(i, j) = dxc(i, j)*uc_tl(i, j)
494  fx(i, j) = uc(i, j)*dxc(i, j)
495  END DO
496  END DO
497  DO j=js,je+1
498  DO i=is-1,ie+1
499  fy_tl(i, j) = dyc(i, j)*vc_tl(i, j)
500  fy(i, j) = vc(i, j)*dyc(i, j)
501  END DO
502  END DO
503  DO j=js,je+1
504  DO i=is,ie+1
505  vort_tl(i, j) = fx_tl(i, j-1) - fx_tl(i, j) + fy_tl(i, j) - &
506 & fy_tl(i-1, j)
507  vort(i, j) = fx(i, j-1) - fx(i, j) + (fy(i, j)-fy(i-1, j))
508  END DO
509  END DO
510 ! Remove the extra term at the corners:
511  IF (sw_corner) THEN
512  vort_tl(1, 1) = vort_tl(1, 1) + fy_tl(0, 1)
513  vort(1, 1) = vort(1, 1) + fy(0, 1)
514  END IF
515  IF (se_corner) THEN
516  vort_tl(npx, 1) = vort_tl(npx, 1) - fy_tl(npx, 1)
517  vort(npx, 1) = vort(npx, 1) - fy(npx, 1)
518  END IF
519  IF (ne_corner) THEN
520  vort_tl(npx, npy) = vort_tl(npx, npy) - fy_tl(npx, npy)
521  vort(npx, npy) = vort(npx, npy) - fy(npx, npy)
522  END IF
523  IF (nw_corner) THEN
524  vort_tl(1, npy) = vort_tl(1, npy) + fy_tl(0, npy)
525  vort(1, npy) = vort(1, npy) + fy(0, npy)
526  END IF
527 !----------------------------
528 ! Compute absolute vorticity
529 !----------------------------
530  DO j=js,je+1
531  DO i=is,ie+1
532  vort_tl(i, j) = gridstruct%rarea_c(i, j)*vort_tl(i, j)
533  vort(i, j) = gridstruct%fc(i, j) + gridstruct%rarea_c(i, j)*vort&
534 & (i, j)
535  END DO
536  END DO
537 !----------------------------------
538 ! Transport absolute vorticity:
539 !----------------------------------
540 !To go from v to contravariant v at the edges, we divide by sin_sg;
541 ! but we then must multiply by sin_sg to get the proper flux.
542 ! These cancel, leaving us with fy1 = dt2*v at the edges.
543 ! (For the same reason we only divide by sin instead of sin**2 in the interior)
544 !! TO DO: separate versions for nesting/single-tile and cubed-sphere
545  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
546  DO j=js,je
547  DO i=is,iep1
548  fy1_tl(i, j) = dt2*(v_tl(i, j)-cosa_u(i, j)*uc_tl(i, j))/&
549 & sina_u(i, j)
550  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
551  IF (fy1(i, j) .GT. 0.) THEN
552  fy_tl(i, j) = vort_tl(i, j)
553  fy(i, j) = vort(i, j)
554  ELSE
555  fy_tl(i, j) = vort_tl(i, j+1)
556  fy(i, j) = vort(i, j+1)
557  END IF
558  END DO
559  END DO
560  DO j=js,jep1
561  DO i=is,ie
562  fx1_tl(i, j) = dt2*(u_tl(i, j)-cosa_v(i, j)*vc_tl(i, j))/&
563 & sina_v(i, j)
564  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
565  IF (fx1(i, j) .GT. 0.) THEN
566  fx_tl(i, j) = vort_tl(i, j)
567  fx(i, j) = vort(i, j)
568  ELSE
569  fx_tl(i, j) = vort_tl(i+1, j)
570  fx(i, j) = vort(i+1, j)
571  END IF
572  END DO
573  END DO
574  ELSE
575  DO j=js,je
576 !DEC$ VECTOR ALWAYS
577  DO i=is,iep1
578  IF (i .EQ. 1 .OR. i .EQ. npx) THEN
579  fy1_tl(i, j) = dt2*v_tl(i, j)
580  fy1(i, j) = dt2*v(i, j)
581  ELSE
582  fy1_tl(i, j) = dt2*(v_tl(i, j)-cosa_u(i, j)*uc_tl(i, j))/&
583 & sina_u(i, j)
584  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
585  END IF
586  IF (fy1(i, j) .GT. 0.) THEN
587  fy_tl(i, j) = vort_tl(i, j)
588  fy(i, j) = vort(i, j)
589  ELSE
590  fy_tl(i, j) = vort_tl(i, j+1)
591  fy(i, j) = vort(i, j+1)
592  END IF
593  END DO
594  END DO
595  DO j=js,jep1
596  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
597 !DEC$ VECTOR ALWAYS
598  DO i=is,ie
599  fx1_tl(i, j) = dt2*u_tl(i, j)
600  fx1(i, j) = dt2*u(i, j)
601  IF (fx1(i, j) .GT. 0.) THEN
602  fx_tl(i, j) = vort_tl(i, j)
603  fx(i, j) = vort(i, j)
604  ELSE
605  fx_tl(i, j) = vort_tl(i+1, j)
606  fx(i, j) = vort(i+1, j)
607  END IF
608  END DO
609  ELSE
610 !DEC$ VECTOR ALWAYS
611  DO i=is,ie
612  fx1_tl(i, j) = dt2*(u_tl(i, j)-cosa_v(i, j)*vc_tl(i, j))/&
613 & sina_v(i, j)
614  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
615  IF (fx1(i, j) .GT. 0.) THEN
616  fx_tl(i, j) = vort_tl(i, j)
617  fx(i, j) = vort(i, j)
618  ELSE
619  fx_tl(i, j) = vort_tl(i+1, j)
620  fx(i, j) = vort(i+1, j)
621  END IF
622  END DO
623  END IF
624  END DO
625  END IF
626 ! Update time-centered winds on the C-Grid
627  DO j=js,je
628  DO i=is,iep1
629  uc_tl(i, j) = uc_tl(i, j) + fy1_tl(i, j)*fy(i, j) + fy1(i, j)*&
630 & fy_tl(i, j) + gridstruct%rdxc(i, j)*(ke_tl(i-1, j)-ke_tl(i, j)&
631 & )
632  uc(i, j) = uc(i, j) + fy1(i, j)*fy(i, j) + gridstruct%rdxc(i, j)&
633 & *(ke(i-1, j)-ke(i, j))
634  END DO
635  END DO
636  DO j=js,jep1
637  DO i=is,ie
638  vc_tl(i, j) = vc_tl(i, j) - fx1_tl(i, j)*fx(i, j) - fx1(i, j)*&
639 & fx_tl(i, j) + gridstruct%rdyc(i, j)*(ke_tl(i, j-1)-ke_tl(i, j)&
640 & )
641  vc(i, j) = vc(i, j) - fx1(i, j)*fx(i, j) + gridstruct%rdyc(i, j)&
642 & *(ke(i, j-1)-ke(i, j))
643  END DO
644  END DO
645  END SUBROUTINE c_sw_tlm
646  SUBROUTINE c_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut&
647 & , vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, &
648 & flagstruct)
649  IMPLICIT NONE
650  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
651  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
652 & , vc
653  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
654 & , uc
655  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
656 & , pt, ua, va, ut, vt
657  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
658  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
659 & , ptc, wc
660  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
661 & divg_d
662  INTEGER, INTENT(IN) :: nord
663  REAL, INTENT(IN) :: dt2
664  LOGICAL, INTENT(IN) :: hydrostatic
665  LOGICAL, INTENT(IN) :: dord4
666  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
667  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
668 ! Local:
669  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
670  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort, ke
671  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx, fx1, fx2
672  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy, fy1, fy2
673  REAL :: dt4
674  INTEGER :: i, j, is2, ie1
675  INTEGER :: iep1, jep1
676  INTEGER :: is, ie, js, je
677  INTEGER :: isd, ied, jsd, jed
678  INTEGER :: npx, npy
679  LOGICAL :: nested
680  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
681  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
682  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
683  REAL, DIMENSION(:, :), POINTER :: dx, dy, dxc, dyc
684  is = bd%is
685  ie = bd%ie
686  js = bd%js
687  je = bd%je
688  isd = bd%isd
689  ied = bd%ied
690  jsd = bd%jsd
691  jed = bd%jed
692  npx = flagstruct%npx
693  npy = flagstruct%npy
694  nested = gridstruct%nested
695  sin_sg => gridstruct%sin_sg
696  cos_sg => gridstruct%cos_sg
697  cosa_u => gridstruct%cosa_u
698  cosa_v => gridstruct%cosa_v
699  sina_u => gridstruct%sina_u
700  sina_v => gridstruct%sina_v
701  dx => gridstruct%dx
702  dy => gridstruct%dy
703  dxc => gridstruct%dxc
704  dyc => gridstruct%dyc
705  sw_corner = gridstruct%sw_corner
706  se_corner = gridstruct%se_corner
707  nw_corner = gridstruct%nw_corner
708  ne_corner = gridstruct%ne_corner
709  iep1 = ie + 1
710  jep1 = je + 1
711  CALL d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd&
712 & , npx, npy, nested, flagstruct%grid_type)
713  IF (nord .GT. 0) THEN
714  IF (nested) THEN
715  CALL divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, &
716 & flagstruct, bd)
717  ELSE
718  CALL divergence_corner(u, v, ua, va, divg_d, gridstruct, &
719 & flagstruct, bd)
720  END IF
721  END IF
722  DO j=js-1,jep1
723  DO i=is-1,iep1+1
724  IF (ut(i, j) .GT. 0.) THEN
725  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i-1, j, 3)
726  ELSE
727  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i, j, 1)
728  END IF
729  END DO
730  END DO
731  DO j=js-1,je+2
732  DO i=is-1,iep1
733  IF (vt(i, j) .GT. 0.) THEN
734  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j-1, 4)
735  ELSE
736  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j, 2)
737  END IF
738  END DO
739  END DO
740 !----------------
741 ! Transport delp:
742 !----------------
743 ! Xdir:
744  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
745 & fill2_4corners(delp, pt, 1, bd, npx, npy, sw_corner, se_corner, &
746 & ne_corner, nw_corner)
747  IF (hydrostatic) THEN
748  DO j=js-1,jep1
749  DO i=is-1,ie+2
750  IF (ut(i, j) .GT. 0.) THEN
751  fx1(i, j) = delp(i-1, j)
752  fx(i, j) = pt(i-1, j)
753  ELSE
754  fx1(i, j) = delp(i, j)
755  fx(i, j) = pt(i, j)
756  END IF
757  fx1(i, j) = ut(i, j)*fx1(i, j)
758  fx(i, j) = fx1(i, j)*fx(i, j)
759  END DO
760  END DO
761  ELSE
762  IF (flagstruct%grid_type .LT. 3) CALL fill_4corners(w, 1, bd, npx&
763 & , npy, sw_corner, &
764 & se_corner, ne_corner&
765 & , nw_corner)
766  DO j=js-1,je+1
767  DO i=is-1,ie+2
768  IF (ut(i, j) .GT. 0.) THEN
769  fx1(i, j) = delp(i-1, j)
770  fx(i, j) = pt(i-1, j)
771  fx2(i, j) = w(i-1, j)
772  ELSE
773  fx1(i, j) = delp(i, j)
774  fx(i, j) = pt(i, j)
775  fx2(i, j) = w(i, j)
776  END IF
777  fx1(i, j) = ut(i, j)*fx1(i, j)
778  fx(i, j) = fx1(i, j)*fx(i, j)
779  fx2(i, j) = fx1(i, j)*fx2(i, j)
780  END DO
781  END DO
782  END IF
783 ! Ydir:
784  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
785 & fill2_4corners(delp, pt, 2, bd, npx, npy, sw_corner, se_corner, &
786 & ne_corner, nw_corner)
787  IF (hydrostatic) THEN
788  DO j=js-1,jep1+1
789  DO i=is-1,iep1
790  IF (vt(i, j) .GT. 0.) THEN
791  fy1(i, j) = delp(i, j-1)
792  fy(i, j) = pt(i, j-1)
793  ELSE
794  fy1(i, j) = delp(i, j)
795  fy(i, j) = pt(i, j)
796  END IF
797  fy1(i, j) = vt(i, j)*fy1(i, j)
798  fy(i, j) = fy1(i, j)*fy(i, j)
799  END DO
800  END DO
801  DO j=js-1,jep1
802  DO i=is-1,iep1
803  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
804 & fy1(i, j+1)))*gridstruct%rarea(i, j)
805  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
806 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
807  END DO
808  END DO
809  ELSE
810  IF (flagstruct%grid_type .LT. 3) CALL fill_4corners(w, 2, bd, npx&
811 & , npy, sw_corner, &
812 & se_corner, ne_corner&
813 & , nw_corner)
814  DO j=js-1,je+2
815  DO i=is-1,ie+1
816  IF (vt(i, j) .GT. 0.) THEN
817  fy1(i, j) = delp(i, j-1)
818  fy(i, j) = pt(i, j-1)
819  fy2(i, j) = w(i, j-1)
820  ELSE
821  fy1(i, j) = delp(i, j)
822  fy(i, j) = pt(i, j)
823  fy2(i, j) = w(i, j)
824  END IF
825  fy1(i, j) = vt(i, j)*fy1(i, j)
826  fy(i, j) = fy1(i, j)*fy(i, j)
827  fy2(i, j) = fy1(i, j)*fy2(i, j)
828  END DO
829  END DO
830  DO j=js-1,je+1
831  DO i=is-1,ie+1
832  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
833 & fy1(i, j+1)))*gridstruct%rarea(i, j)
834  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
835 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
836  wc(i, j) = (w(i, j)*delp(i, j)+(fx2(i, j)-fx2(i+1, j)+(fy2(i, &
837 & j)-fy2(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
838  END DO
839  END DO
840  END IF
841 !------------
842 ! Compute KE:
843 !------------
844 !Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the tru
845 !e coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa.
846 !Use the alpha for the cell KE is being computed in.
847 !!! TO DO:
848 !!! Need separate versions for nesting/single-tile
849 !!! and for cubed-sphere
850  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
851  DO j=js-1,jep1
852  DO i=is-1,iep1
853  IF (ua(i, j) .GT. 0.) THEN
854  ke(i, j) = uc(i, j)
855  ELSE
856  ke(i, j) = uc(i+1, j)
857  END IF
858  END DO
859  END DO
860  DO j=js-1,jep1
861  DO i=is-1,iep1
862  IF (va(i, j) .GT. 0.) THEN
863  vort(i, j) = vc(i, j)
864  ELSE
865  vort(i, j) = vc(i, j+1)
866  END IF
867  END DO
868  END DO
869  ELSE
870  DO j=js-1,jep1
871  DO i=is-1,iep1
872  IF (ua(i, j) .GT. 0.) THEN
873  IF (i .EQ. 1) THEN
874  ke(1, j) = uc(1, j)*sin_sg(1, j, 1) + v(1, j)*cos_sg(1, j&
875 & , 1)
876  ELSE IF (i .EQ. npx) THEN
877  ke(i, j) = uc(npx, j)*sin_sg(npx, j, 1) + v(npx, j)*cos_sg&
878 & (npx, j, 1)
879  ELSE
880  ke(i, j) = uc(i, j)
881  END IF
882  ELSE IF (i .EQ. 0) THEN
883  ke(0, j) = uc(1, j)*sin_sg(0, j, 3) + v(1, j)*cos_sg(0, j, 3&
884 & )
885  ELSE IF (i .EQ. npx - 1) THEN
886  ke(i, j) = uc(npx, j)*sin_sg(npx-1, j, 3) + v(npx, j)*cos_sg&
887 & (npx-1, j, 3)
888  ELSE
889  ke(i, j) = uc(i+1, j)
890  END IF
891  END DO
892  END DO
893  DO j=js-1,jep1
894  DO i=is-1,iep1
895  IF (va(i, j) .GT. 0.) THEN
896  IF (j .EQ. 1) THEN
897  vort(i, 1) = vc(i, 1)*sin_sg(i, 1, 2) + u(i, 1)*cos_sg(i, &
898 & 1, 2)
899  ELSE IF (j .EQ. npy) THEN
900  vort(i, j) = vc(i, npy)*sin_sg(i, npy, 2) + u(i, npy)*&
901 & cos_sg(i, npy, 2)
902  ELSE
903  vort(i, j) = vc(i, j)
904  END IF
905  ELSE IF (j .EQ. 0) THEN
906  vort(i, 0) = vc(i, 1)*sin_sg(i, 0, 4) + u(i, 1)*cos_sg(i, 0&
907 & , 4)
908  ELSE IF (j .EQ. npy - 1) THEN
909  vort(i, j) = vc(i, npy)*sin_sg(i, npy-1, 4) + u(i, npy)*&
910 & cos_sg(i, npy-1, 4)
911  ELSE
912  vort(i, j) = vc(i, j+1)
913  END IF
914  END DO
915  END DO
916  END IF
917  dt4 = 0.5*dt2
918  DO j=js-1,jep1
919  DO i=is-1,iep1
920  ke(i, j) = dt4*(ua(i, j)*ke(i, j)+va(i, j)*vort(i, j))
921  END DO
922  END DO
923 !------------------------------
924 ! Compute circulation on C grid
925 !------------------------------
926 ! To consider using true co-variant winds at face edges?
927  DO j=js-1,je+1
928  DO i=is,ie+1
929  fx(i, j) = uc(i, j)*dxc(i, j)
930  END DO
931  END DO
932  DO j=js,je+1
933  DO i=is-1,ie+1
934  fy(i, j) = vc(i, j)*dyc(i, j)
935  END DO
936  END DO
937  DO j=js,je+1
938  DO i=is,ie+1
939  vort(i, j) = fx(i, j-1) - fx(i, j) + (fy(i, j)-fy(i-1, j))
940  END DO
941  END DO
942 ! Remove the extra term at the corners:
943  IF (sw_corner) vort(1, 1) = vort(1, 1) + fy(0, 1)
944  IF (se_corner) vort(npx, 1) = vort(npx, 1) - fy(npx, 1)
945  IF (ne_corner) vort(npx, npy) = vort(npx, npy) - fy(npx, npy)
946  IF (nw_corner) vort(1, npy) = vort(1, npy) + fy(0, npy)
947 !----------------------------
948 ! Compute absolute vorticity
949 !----------------------------
950  DO j=js,je+1
951  DO i=is,ie+1
952  vort(i, j) = gridstruct%fc(i, j) + gridstruct%rarea_c(i, j)*vort&
953 & (i, j)
954  END DO
955  END DO
956 !----------------------------------
957 ! Transport absolute vorticity:
958 !----------------------------------
959 !To go from v to contravariant v at the edges, we divide by sin_sg;
960 ! but we then must multiply by sin_sg to get the proper flux.
961 ! These cancel, leaving us with fy1 = dt2*v at the edges.
962 ! (For the same reason we only divide by sin instead of sin**2 in the interior)
963 !! TO DO: separate versions for nesting/single-tile and cubed-sphere
964  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
965  DO j=js,je
966  DO i=is,iep1
967  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
968  IF (fy1(i, j) .GT. 0.) THEN
969  fy(i, j) = vort(i, j)
970  ELSE
971  fy(i, j) = vort(i, j+1)
972  END IF
973  END DO
974  END DO
975  DO j=js,jep1
976  DO i=is,ie
977  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
978  IF (fx1(i, j) .GT. 0.) THEN
979  fx(i, j) = vort(i, j)
980  ELSE
981  fx(i, j) = vort(i+1, j)
982  END IF
983  END DO
984  END DO
985  ELSE
986  DO j=js,je
987 !DEC$ VECTOR ALWAYS
988  DO i=is,iep1
989  IF (i .EQ. 1 .OR. i .EQ. npx) THEN
990  fy1(i, j) = dt2*v(i, j)
991  ELSE
992  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
993  END IF
994  IF (fy1(i, j) .GT. 0.) THEN
995  fy(i, j) = vort(i, j)
996  ELSE
997  fy(i, j) = vort(i, j+1)
998  END IF
999  END DO
1000  END DO
1001  DO j=js,jep1
1002  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
1003 !DEC$ VECTOR ALWAYS
1004  DO i=is,ie
1005  fx1(i, j) = dt2*u(i, j)
1006  IF (fx1(i, j) .GT. 0.) THEN
1007  fx(i, j) = vort(i, j)
1008  ELSE
1009  fx(i, j) = vort(i+1, j)
1010  END IF
1011  END DO
1012  ELSE
1013 !DEC$ VECTOR ALWAYS
1014  DO i=is,ie
1015  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
1016  IF (fx1(i, j) .GT. 0.) THEN
1017  fx(i, j) = vort(i, j)
1018  ELSE
1019  fx(i, j) = vort(i+1, j)
1020  END IF
1021  END DO
1022  END IF
1023  END DO
1024  END IF
1025 ! Update time-centered winds on the C-Grid
1026  DO j=js,je
1027  DO i=is,iep1
1028  uc(i, j) = uc(i, j) + fy1(i, j)*fy(i, j) + gridstruct%rdxc(i, j)&
1029 & *(ke(i-1, j)-ke(i, j))
1030  END DO
1031  END DO
1032  DO j=js,jep1
1033  DO i=is,ie
1034  vc(i, j) = vc(i, j) - fx1(i, j)*fx(i, j) + gridstruct%rdyc(i, j)&
1035 & *(ke(i, j-1)-ke(i, j))
1036  END DO
1037  END DO
1038  END SUBROUTINE c_sw
1039 ! Differentiation of d_sw in forward (tangent) mode:
1040 ! variations of useful results: yfx_adv q crx_adv u v w delp
1041 ! xfx_adv uc ptc xflux cry_adv delpc vc yflux divg_d
1042 ! heat_source pt cx cy dpx
1043 ! with respect to varying inputs: yfx_adv q crx_adv u v w delp
1044 ! ua xfx_adv uc ptc xflux cry_adv delpc va vc yflux
1045 ! divg_d z_rat heat_source pt cx cy dpx
1046 ! d_sw :: D-Grid Shallow Water Routine
1047  SUBROUTINE d_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, &
1048 & pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, &
1049 & va, va_tl, divg_d, divg_d_tl, xflux, xflux_tl, yflux, yflux_tl, cx, &
1050 & cx_tl, cy, cy_tl, crx_adv, crx_adv_tl, cry_adv, cry_adv_tl, xfx_adv&
1051 & , xfx_adv_tl, yfx_adv, yfx_adv_tl, q_con, z_rat, z_rat_tl, kgb, &
1052 & heat_source, heat_source_tl, dpx, dpx_tl, zvir, sphum, nq, q, q_tl, &
1053 & k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, &
1054 & nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, &
1055 & damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert&
1056 & , hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp&
1057 & , nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, &
1058 & d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
1059  IMPLICIT NONE
1060  INTEGER, INTENT(IN) :: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
1061 ! nord=1 divergence damping; (del-4) or 3 (del-8)
1062  INTEGER, INTENT(IN) :: nord
1063 ! vorticity damping
1064  INTEGER, INTENT(IN) :: nord_v
1065 ! vertical velocity
1066  INTEGER, INTENT(IN) :: nord_w
1067 ! pt
1068  INTEGER, INTENT(IN) :: nord_t
1069  INTEGER, INTENT(IN) :: sphum, nq, k, km
1070  REAL, INTENT(IN) :: dt, dddmp, d2_bg, d4_bg, d_con
1071  REAL, INTENT(IN) :: zvir
1072  REAL, INTENT(IN) :: damp_v, damp_w, damp_t, kgb
1073  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1074  INTEGER, INTENT(IN) :: hord_tr_pert, hord_mt_pert, hord_vt_pert, &
1075 & hord_tm_pert, hord_dp_pert, nord_pert, nord_v_pert, nord_w_pert, &
1076 & nord_t_pert
1077  LOGICAL, INTENT(IN) :: split_damp
1078  REAL, INTENT(IN) :: dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert&
1079 & , damp_w_pert, damp_t_pert
1080 ! divergence
1081  REAL, INTENT(INOUT) :: divg_d(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1082  REAL, INTENT(INOUT) :: divg_d_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1083  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: z_rat
1084  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: &
1085 & z_rat_tl
1086  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
1087 & , pt, ua, va
1088  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
1089 & delp_tl, pt_tl, ua_tl, va_tl
1090  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
1091  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w_tl
1092  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
1093 & q_con
1094  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
1095 & , vc
1096  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
1097 & u_tl, vc_tl
1098  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
1099 & , uc
1100  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
1101 & v_tl, uc_tl
1102  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
1103  REAL, INTENT(INOUT) :: q_tl(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
1104  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
1105 & , ptc
1106  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: &
1107 & delpc_tl, ptc_tl
1108  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(OUT) :: &
1109 & heat_source
1110  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(OUT) :: &
1111 & heat_source_tl
1112  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
1113 & dpx
1114  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
1115 & dpx_tl
1116 ! The flux capacitors:
1117  REAL, INTENT(INOUT) :: xflux(bd%is:bd%ie+1, bd%js:bd%je)
1118  REAL, INTENT(INOUT) :: xflux_tl(bd%is:bd%ie+1, bd%js:bd%je)
1119  REAL, INTENT(INOUT) :: yflux(bd%is:bd%ie, bd%js:bd%je+1)
1120  REAL, INTENT(INOUT) :: yflux_tl(bd%is:bd%ie, bd%js:bd%je+1)
1121 !------------------------
1122  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed)
1123  REAL, INTENT(INOUT) :: cx_tl(bd%is:bd%ie+1, bd%jsd:bd%jed)
1124  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1)
1125  REAL, INTENT(INOUT) :: cy_tl(bd%isd:bd%ied, bd%js:bd%je+1)
1126  LOGICAL, INTENT(IN) :: hydrostatic
1127  LOGICAL, INTENT(IN) :: inline_q
1128  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed), INTENT(OUT) :: &
1129 & crx_adv, xfx_adv
1130  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed), INTENT(OUT) :: &
1131 & crx_adv_tl, xfx_adv_tl
1132  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1), INTENT(OUT) :: &
1133 & cry_adv, yfx_adv
1134  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1), INTENT(OUT) :: &
1135 & cry_adv_tl, yfx_adv_tl
1136  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1137  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
1138 ! Local:
1139  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
1140  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1141  REAL :: ut_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1142  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1143  REAL :: vt_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1144 !---
1145  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1146  REAL :: fx2_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1147  REAL :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1148  REAL :: fy2_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1149 ! work array
1150  REAL :: dw(bd%is:bd%ie, bd%js:bd%je)
1151  REAL :: dw_tl(bd%is:bd%ie, bd%js:bd%je)
1152 !---
1153  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub, vb
1154  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub_tl, vb_tl
1155 ! work array
1156  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
1157  REAL :: wk_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
1158 ! needs this for corner_comm
1159  REAL :: ke(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1160  REAL :: ke_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1161 ! Vorticity
1162  REAL :: vort(bd%isd:bd%ied, bd%jsd:bd%jed)
1163  REAL :: vort_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
1164 ! 1-D X-direction Fluxes
1165  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
1166  REAL :: fx_tl(bd%is:bd%ie+1, bd%js:bd%je)
1167 ! 1-D Y-direction Fluxes
1168  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
1169  REAL :: fy_tl(bd%is:bd%ie, bd%js:bd%je+1)
1170  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
1171  REAL :: ra_x_tl(bd%is:bd%ie, bd%jsd:bd%jed)
1172  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
1173  REAL :: ra_y_tl(bd%isd:bd%ied, bd%js:bd%je)
1174  REAL :: gx(bd%is:bd%ie+1, bd%js:bd%je)
1175  REAL :: gx_tl(bd%is:bd%ie+1, bd%js:bd%je)
1176 ! work Y-dir flux array
1177  REAL :: gy(bd%is:bd%ie, bd%js:bd%je+1)
1178  REAL :: gy_tl(bd%is:bd%ie, bd%js:bd%je+1)
1179  LOGICAL :: fill_c
1180  REAL :: dt2, dt4, dt5, dt6
1181  REAL :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
1182  REAL :: u2_tl, v2_tl, du2_tl, dv2_tl
1183  REAL :: u_lon
1184  INTEGER :: i, j, is2, ie1, js2, je1, n, nt, n2, iq
1185  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
1186  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
1187  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
1188  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
1189  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
1190  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
1191  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
1192 & , rdx, rdy
1193  INTEGER :: is, ie, js, je
1194  INTEGER :: isd, ied, jsd, jed
1195  INTEGER :: npx, npy
1196  LOGICAL :: nested
1197  REAL :: delp_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1198  REAL :: pt_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1199  REAL :: vort_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1200  REAL :: wk_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1201  REAL :: delpc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1202  REAL :: ptc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1203  REAL :: ke_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1204  REAL :: vc_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1205  REAL :: uc_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1206  REAL :: divg_d_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1207  REAL :: ut_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1208  REAL :: vt_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1209  INTRINSIC max
1210  INTRINSIC min
1211  INTRINSIC abs
1212  INTEGER :: max1
1213  INTEGER :: max2
1214  INTEGER :: max3
1215  INTEGER :: max4
1216  REAL :: abs0
1217  INTEGER :: min1
1218  INTEGER :: min2
1219  INTEGER :: min3
1220  INTEGER :: min4
1221  REAL*8 :: pwx1
1222  INTEGER :: pwy1
1223  is = bd%is
1224  ie = bd%ie
1225  js = bd%js
1226  je = bd%je
1227  isd = bd%isd
1228  ied = bd%ied
1229  jsd = bd%jsd
1230  jed = bd%jed
1231  npx = flagstruct%npx
1232  npy = flagstruct%npy
1233  nested = gridstruct%nested
1234  area => gridstruct%area
1235  rarea => gridstruct%rarea
1236  sin_sg => gridstruct%sin_sg
1237  cosa_u => gridstruct%cosa_u
1238  cosa_v => gridstruct%cosa_v
1239  cosa_s => gridstruct%cosa_s
1240  sina_u => gridstruct%sina_u
1241  sina_v => gridstruct%sina_v
1242  rsin_u => gridstruct%rsin_u
1243  rsin_v => gridstruct%rsin_v
1244  rsina => gridstruct%rsina
1245  f0 => gridstruct%f0
1246  rsin2 => gridstruct%rsin2
1247  divg_u => gridstruct%divg_u
1248  divg_v => gridstruct%divg_v
1249  cosa => gridstruct%cosa
1250  dx => gridstruct%dx
1251  dy => gridstruct%dy
1252  dxc => gridstruct%dxc
1253  dyc => gridstruct%dyc
1254  rdxa => gridstruct%rdxa
1255  rdya => gridstruct%rdya
1256  rdx => gridstruct%rdx
1257  rdy => gridstruct%rdy
1258  sw_corner = gridstruct%sw_corner
1259  se_corner = gridstruct%se_corner
1260  nw_corner = gridstruct%nw_corner
1261  ne_corner = gridstruct%ne_corner
1262 ! end grid_type choices
1263  IF (flagstruct%grid_type .LT. 3) THEN
1264 !!! TO DO: separate versions for nesting and for cubed-sphere
1265  IF (nested) THEN
1266  ut_tl = 0.0
1267  DO j=jsd,jed
1268  DO i=is-1,ie+2
1269  ut_tl(i, j) = rsin_u(i, j)*(uc_tl(i, j)-0.25*cosa_u(i, j)*(&
1270 & vc_tl(i-1, j)+vc_tl(i, j)+vc_tl(i-1, j+1)+vc_tl(i, j+1)))
1271  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j)+&
1272 & vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
1273  END DO
1274  END DO
1275  vt_tl = 0.0
1276  DO j=js-1,je+2
1277  DO i=isd,ied
1278  vt_tl(i, j) = rsin_v(i, j)*(vc_tl(i, j)-0.25*cosa_v(i, j)*(&
1279 & uc_tl(i, j-1)+uc_tl(i+1, j-1)+uc_tl(i, j)+uc_tl(i+1, j)))
1280  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1, j&
1281 & -1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
1282  END DO
1283  END DO
1284  ELSE
1285  ut_tl = 0.0
1286  DO j=jsd,jed
1287  IF (j .NE. 0 .AND. j .NE. 1 .AND. j .NE. npy - 1 .AND. j .NE. &
1288 & npy) THEN
1289  DO i=is-1,ie+2
1290  ut_tl(i, j) = rsin_u(i, j)*(uc_tl(i, j)-0.25*cosa_u(i, j)*&
1291 & (vc_tl(i-1, j)+vc_tl(i, j)+vc_tl(i-1, j+1)+vc_tl(i, j+1)&
1292 & ))
1293  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j&
1294 & )+vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
1295  END DO
1296  END IF
1297  END DO
1298  vt_tl = 0.0
1299  DO j=js-1,je+2
1300  IF (j .NE. 1 .AND. j .NE. npy) THEN
1301  DO i=isd,ied
1302  vt_tl(i, j) = rsin_v(i, j)*(vc_tl(i, j)-0.25*cosa_v(i, j)*&
1303 & (uc_tl(i, j-1)+uc_tl(i+1, j-1)+uc_tl(i, j)+uc_tl(i+1, j)&
1304 & ))
1305  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1&
1306 & , j-1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
1307  END DO
1308  END IF
1309  END DO
1310  END IF
1311 !.not. nested
1312  IF (.NOT.nested) THEN
1313 ! West face
1314 ! West edge:
1315  IF (is .EQ. 1) THEN
1316  DO j=jsd,jed
1317  IF (uc(1, j)*dt .GT. 0.) THEN
1318  ut_tl(1, j) = uc_tl(1, j)/sin_sg(0, j, 3)
1319  ut(1, j) = uc(1, j)/sin_sg(0, j, 3)
1320  ELSE
1321  ut_tl(1, j) = uc_tl(1, j)/sin_sg(1, j, 1)
1322  ut(1, j) = uc(1, j)/sin_sg(1, j, 1)
1323  END IF
1324  END DO
1325  IF (3 .LT. js) THEN
1326  max1 = js
1327  ELSE
1328  max1 = 3
1329  END IF
1330  IF (npy - 2 .GT. je + 1) THEN
1331  min1 = je + 1
1332  ELSE
1333  min1 = npy - 2
1334  END IF
1335  DO j=max1,min1
1336  vt_tl(0, j) = vc_tl(0, j) - 0.25*cosa_v(0, j)*(ut_tl(0, j-1)&
1337 & +ut_tl(1, j-1)+ut_tl(0, j)+ut_tl(1, j))
1338  vt(0, j) = vc(0, j) - 0.25*cosa_v(0, j)*(ut(0, j-1)+ut(1, j-&
1339 & 1)+ut(0, j)+ut(1, j))
1340  vt_tl(1, j) = vc_tl(1, j) - 0.25*cosa_v(1, j)*(ut_tl(1, j-1)&
1341 & +ut_tl(2, j-1)+ut_tl(1, j)+ut_tl(2, j))
1342  vt(1, j) = vc(1, j) - 0.25*cosa_v(1, j)*(ut(1, j-1)+ut(2, j-&
1343 & 1)+ut(1, j)+ut(2, j))
1344  END DO
1345  END IF
1346 ! East edge:
1347  IF (ie + 1 .EQ. npx) THEN
1348  DO j=jsd,jed
1349  IF (uc(npx, j)*dt .GT. 0.) THEN
1350  ut_tl(npx, j) = uc_tl(npx, j)/sin_sg(npx-1, j, 3)
1351  ut(npx, j) = uc(npx, j)/sin_sg(npx-1, j, 3)
1352  ELSE
1353  ut_tl(npx, j) = uc_tl(npx, j)/sin_sg(npx, j, 1)
1354  ut(npx, j) = uc(npx, j)/sin_sg(npx, j, 1)
1355  END IF
1356  END DO
1357  IF (3 .LT. js) THEN
1358  max2 = js
1359  ELSE
1360  max2 = 3
1361  END IF
1362  IF (npy - 2 .GT. je + 1) THEN
1363  min2 = je + 1
1364  ELSE
1365  min2 = npy - 2
1366  END IF
1367  DO j=max2,min2
1368  vt_tl(npx-1, j) = vc_tl(npx-1, j) - 0.25*cosa_v(npx-1, j)*(&
1369 & ut_tl(npx-1, j-1)+ut_tl(npx, j-1)+ut_tl(npx-1, j)+ut_tl(&
1370 & npx, j))
1371  vt(npx-1, j) = vc(npx-1, j) - 0.25*cosa_v(npx-1, j)*(ut(npx-&
1372 & 1, j-1)+ut(npx, j-1)+ut(npx-1, j)+ut(npx, j))
1373  vt_tl(npx, j) = vc_tl(npx, j) - 0.25*cosa_v(npx, j)*(ut_tl(&
1374 & npx, j-1)+ut_tl(npx+1, j-1)+ut_tl(npx, j)+ut_tl(npx+1, j))
1375  vt(npx, j) = vc(npx, j) - 0.25*cosa_v(npx, j)*(ut(npx, j-1)+&
1376 & ut(npx+1, j-1)+ut(npx, j)+ut(npx+1, j))
1377  END DO
1378  END IF
1379 ! South (Bottom) edge:
1380  IF (js .EQ. 1) THEN
1381  DO i=isd,ied
1382  IF (vc(i, 1)*dt .GT. 0.) THEN
1383  vt_tl(i, 1) = vc_tl(i, 1)/sin_sg(i, 0, 4)
1384  vt(i, 1) = vc(i, 1)/sin_sg(i, 0, 4)
1385  ELSE
1386  vt_tl(i, 1) = vc_tl(i, 1)/sin_sg(i, 1, 2)
1387  vt(i, 1) = vc(i, 1)/sin_sg(i, 1, 2)
1388  END IF
1389  END DO
1390  IF (3 .LT. is) THEN
1391  max3 = is
1392  ELSE
1393  max3 = 3
1394  END IF
1395  IF (npx - 2 .GT. ie + 1) THEN
1396  min3 = ie + 1
1397  ELSE
1398  min3 = npx - 2
1399  END IF
1400  DO i=max3,min3
1401  ut_tl(i, 0) = uc_tl(i, 0) - 0.25*cosa_u(i, 0)*(vt_tl(i-1, 0)&
1402 & +vt_tl(i, 0)+vt_tl(i-1, 1)+vt_tl(i, 1))
1403  ut(i, 0) = uc(i, 0) - 0.25*cosa_u(i, 0)*(vt(i-1, 0)+vt(i, 0)&
1404 & +vt(i-1, 1)+vt(i, 1))
1405  ut_tl(i, 1) = uc_tl(i, 1) - 0.25*cosa_u(i, 1)*(vt_tl(i-1, 1)&
1406 & +vt_tl(i, 1)+vt_tl(i-1, 2)+vt_tl(i, 2))
1407  ut(i, 1) = uc(i, 1) - 0.25*cosa_u(i, 1)*(vt(i-1, 1)+vt(i, 1)&
1408 & +vt(i-1, 2)+vt(i, 2))
1409  END DO
1410  END IF
1411 ! North edge:
1412  IF (je + 1 .EQ. npy) THEN
1413  DO i=isd,ied
1414  IF (vc(i, npy)*dt .GT. 0.) THEN
1415  vt_tl(i, npy) = vc_tl(i, npy)/sin_sg(i, npy-1, 4)
1416  vt(i, npy) = vc(i, npy)/sin_sg(i, npy-1, 4)
1417  ELSE
1418  vt_tl(i, npy) = vc_tl(i, npy)/sin_sg(i, npy, 2)
1419  vt(i, npy) = vc(i, npy)/sin_sg(i, npy, 2)
1420  END IF
1421  END DO
1422  IF (3 .LT. is) THEN
1423  max4 = is
1424  ELSE
1425  max4 = 3
1426  END IF
1427  IF (npx - 2 .GT. ie + 1) THEN
1428  min4 = ie + 1
1429  ELSE
1430  min4 = npx - 2
1431  END IF
1432  DO i=max4,min4
1433  ut_tl(i, npy-1) = uc_tl(i, npy-1) - 0.25*cosa_u(i, npy-1)*(&
1434 & vt_tl(i-1, npy-1)+vt_tl(i, npy-1)+vt_tl(i-1, npy)+vt_tl(i&
1435 & , npy))
1436  ut(i, npy-1) = uc(i, npy-1) - 0.25*cosa_u(i, npy-1)*(vt(i-1&
1437 & , npy-1)+vt(i, npy-1)+vt(i-1, npy)+vt(i, npy))
1438  ut_tl(i, npy) = uc_tl(i, npy) - 0.25*cosa_u(i, npy)*(vt_tl(i&
1439 & -1, npy)+vt_tl(i, npy)+vt_tl(i-1, npy+1)+vt_tl(i, npy+1))
1440  ut(i, npy) = uc(i, npy) - 0.25*cosa_u(i, npy)*(vt(i-1, npy)+&
1441 & vt(i, npy)+vt(i-1, npy+1)+vt(i, npy+1))
1442  END DO
1443  END IF
1444 ! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values
1445 ! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously).
1446 ! It then computes the halo uc, vc values so as to be consistent with the computations on
1447 ! the facing panel.
1448 !The system solved is:
1449 ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1)
1450 ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2)
1451 ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1)
1452  IF (sw_corner) THEN
1453  damp = 1./(1.-0.0625*cosa_u(2, 0)*cosa_v(1, 0))
1454  ut_tl(2, 0) = damp*(uc_tl(2, 0)-0.25*cosa_u(2, 0)*(vt_tl(1, 1)&
1455 & +vt_tl(2, 1)+vt_tl(2, 0)+vc_tl(1, 0)-0.25*cosa_v(1, 0)*(&
1456 & ut_tl(1, 0)+ut_tl(1, -1)+ut_tl(2, -1))))
1457  ut(2, 0) = (uc(2, 0)-0.25*cosa_u(2, 0)*(vt(1, 1)+vt(2, 1)+vt(2&
1458 & , 0)+vc(1, 0)-0.25*cosa_v(1, 0)*(ut(1, 0)+ut(1, -1)+ut(2, -1&
1459 & ))))*damp
1460  damp = 1./(1.-0.0625*cosa_u(0, 1)*cosa_v(0, 2))
1461  vt_tl(0, 2) = damp*(vc_tl(0, 2)-0.25*cosa_v(0, 2)*(ut_tl(1, 1)&
1462 & +ut_tl(1, 2)+ut_tl(0, 2)+uc_tl(0, 1)-0.25*cosa_u(0, 1)*(&
1463 & vt_tl(0, 1)+vt_tl(-1, 1)+vt_tl(-1, 2))))
1464  vt(0, 2) = (vc(0, 2)-0.25*cosa_v(0, 2)*(ut(1, 1)+ut(1, 2)+ut(0&
1465 & , 2)+uc(0, 1)-0.25*cosa_u(0, 1)*(vt(0, 1)+vt(-1, 1)+vt(-1, 2&
1466 & ))))*damp
1467  damp = 1./(1.-0.0625*cosa_u(2, 1)*cosa_v(1, 2))
1468  ut_tl(2, 1) = damp*(uc_tl(2, 1)-0.25*cosa_u(2, 1)*(vt_tl(1, 1)&
1469 & +vt_tl(2, 1)+vt_tl(2, 2)+vc_tl(1, 2)-0.25*cosa_v(1, 2)*(&
1470 & ut_tl(1, 1)+ut_tl(1, 2)+ut_tl(2, 2))))
1471  ut(2, 1) = (uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2&
1472 & , 2)+vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2, 2))&
1473 & ))*damp
1474  vt_tl(1, 2) = damp*(vc_tl(1, 2)-0.25*cosa_v(1, 2)*(ut_tl(1, 1)&
1475 & +ut_tl(1, 2)+ut_tl(2, 2)+uc_tl(2, 1)-0.25*cosa_u(2, 1)*(&
1476 & vt_tl(1, 1)+vt_tl(2, 1)+vt_tl(2, 2))))
1477  vt(1, 2) = (vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2&
1478 & , 2)+uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2, 2))&
1479 & ))*damp
1480  END IF
1481  IF (se_corner) THEN
1482  damp = 1./(1.-0.0625*cosa_u(npx-1, 0)*cosa_v(npx-1, 0))
1483  ut_tl(npx-1, 0) = damp*(uc_tl(npx-1, 0)-0.25*cosa_u(npx-1, 0)*&
1484 & (vt_tl(npx-1, 1)+vt_tl(npx-2, 1)+vt_tl(npx-2, 0)+vc_tl(npx-1&
1485 & , 0)-0.25*cosa_v(npx-1, 0)*(ut_tl(npx, 0)+ut_tl(npx, -1)+&
1486 & ut_tl(npx-1, -1))))
1487  ut(npx-1, 0) = (uc(npx-1, 0)-0.25*cosa_u(npx-1, 0)*(vt(npx-1, &
1488 & 1)+vt(npx-2, 1)+vt(npx-2, 0)+vc(npx-1, 0)-0.25*cosa_v(npx-1&
1489 & , 0)*(ut(npx, 0)+ut(npx, -1)+ut(npx-1, -1))))*damp
1490  damp = 1./(1.-0.0625*cosa_u(npx+1, 1)*cosa_v(npx, 2))
1491  vt_tl(npx, 2) = damp*(vc_tl(npx, 2)-0.25*cosa_v(npx, 2)*(ut_tl&
1492 & (npx, 1)+ut_tl(npx, 2)+ut_tl(npx+1, 2)+uc_tl(npx+1, 1)-0.25*&
1493 & cosa_u(npx+1, 1)*(vt_tl(npx, 1)+vt_tl(npx+1, 1)+vt_tl(npx+1&
1494 & , 2))))
1495  vt(npx, 2) = (vc(npx, 2)-0.25*cosa_v(npx, 2)*(ut(npx, 1)+ut(&
1496 & npx, 2)+ut(npx+1, 2)+uc(npx+1, 1)-0.25*cosa_u(npx+1, 1)*(vt(&
1497 & npx, 1)+vt(npx+1, 1)+vt(npx+1, 2))))*damp
1498  damp = 1./(1.-0.0625*cosa_u(npx-1, 1)*cosa_v(npx-1, 2))
1499  ut_tl(npx-1, 1) = damp*(uc_tl(npx-1, 1)-0.25*cosa_u(npx-1, 1)*&
1500 & (vt_tl(npx-1, 1)+vt_tl(npx-2, 1)+vt_tl(npx-2, 2)+vc_tl(npx-1&
1501 & , 2)-0.25*cosa_v(npx-1, 2)*(ut_tl(npx, 1)+ut_tl(npx, 2)+&
1502 & ut_tl(npx-1, 2))))
1503  ut(npx-1, 1) = (uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*(vt(npx-1, &
1504 & 1)+vt(npx-2, 1)+vt(npx-2, 2)+vc(npx-1, 2)-0.25*cosa_v(npx-1&
1505 & , 2)*(ut(npx, 1)+ut(npx, 2)+ut(npx-1, 2))))*damp
1506  vt_tl(npx-1, 2) = damp*(vc_tl(npx-1, 2)-0.25*cosa_v(npx-1, 2)*&
1507 & (ut_tl(npx, 1)+ut_tl(npx, 2)+ut_tl(npx-1, 2)+uc_tl(npx-1, 1)&
1508 & -0.25*cosa_u(npx-1, 1)*(vt_tl(npx-1, 1)+vt_tl(npx-2, 1)+&
1509 & vt_tl(npx-2, 2))))
1510  vt(npx-1, 2) = (vc(npx-1, 2)-0.25*cosa_v(npx-1, 2)*(ut(npx, 1)&
1511 & +ut(npx, 2)+ut(npx-1, 2)+uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*&
1512 & (vt(npx-1, 1)+vt(npx-2, 1)+vt(npx-2, 2))))*damp
1513  END IF
1514  IF (ne_corner) THEN
1515  damp = 1./(1.-0.0625*cosa_u(npx-1, npy)*cosa_v(npx-1, npy+1))
1516  ut_tl(npx-1, npy) = damp*(uc_tl(npx-1, npy)-0.25*cosa_u(npx-1&
1517 & , npy)*(vt_tl(npx-1, npy)+vt_tl(npx-2, npy)+vt_tl(npx-2, npy&
1518 & +1)+vc_tl(npx-1, npy+1)-0.25*cosa_v(npx-1, npy+1)*(ut_tl(npx&
1519 & , npy)+ut_tl(npx, npy+1)+ut_tl(npx-1, npy+1))))
1520  ut(npx-1, npy) = (uc(npx-1, npy)-0.25*cosa_u(npx-1, npy)*(vt(&
1521 & npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy+1)+vc(npx-1, npy+1)&
1522 & -0.25*cosa_v(npx-1, npy+1)*(ut(npx, npy)+ut(npx, npy+1)+ut(&
1523 & npx-1, npy+1))))*damp
1524  damp = 1./(1.-0.0625*cosa_u(npx+1, npy-1)*cosa_v(npx, npy-1))
1525  vt_tl(npx, npy-1) = damp*(vc_tl(npx, npy-1)-0.25*cosa_v(npx, &
1526 & npy-1)*(ut_tl(npx, npy-1)+ut_tl(npx, npy-2)+ut_tl(npx+1, npy&
1527 & -2)+uc_tl(npx+1, npy-1)-0.25*cosa_u(npx+1, npy-1)*(vt_tl(npx&
1528 & , npy)+vt_tl(npx+1, npy)+vt_tl(npx+1, npy-1))))
1529  vt(npx, npy-1) = (vc(npx, npy-1)-0.25*cosa_v(npx, npy-1)*(ut(&
1530 & npx, npy-1)+ut(npx, npy-2)+ut(npx+1, npy-2)+uc(npx+1, npy-1)&
1531 & -0.25*cosa_u(npx+1, npy-1)*(vt(npx, npy)+vt(npx+1, npy)+vt(&
1532 & npx+1, npy-1))))*damp
1533  damp = 1./(1.-0.0625*cosa_u(npx-1, npy-1)*cosa_v(npx-1, npy-1)&
1534 & )
1535  ut_tl(npx-1, npy-1) = damp*(uc_tl(npx-1, npy-1)-0.25*cosa_u(&
1536 & npx-1, npy-1)*(vt_tl(npx-1, npy)+vt_tl(npx-2, npy)+vt_tl(npx&
1537 & -2, npy-1)+vc_tl(npx-1, npy-1)-0.25*cosa_v(npx-1, npy-1)*(&
1538 & ut_tl(npx, npy-1)+ut_tl(npx, npy-2)+ut_tl(npx-1, npy-2))))
1539  ut(npx-1, npy-1) = (uc(npx-1, npy-1)-0.25*cosa_u(npx-1, npy-1)&
1540 & *(vt(npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy-1)+vc(npx-1, &
1541 & npy-1)-0.25*cosa_v(npx-1, npy-1)*(ut(npx, npy-1)+ut(npx, npy&
1542 & -2)+ut(npx-1, npy-2))))*damp
1543  vt_tl(npx-1, npy-1) = damp*(vc_tl(npx-1, npy-1)-0.25*cosa_v(&
1544 & npx-1, npy-1)*(ut_tl(npx, npy-1)+ut_tl(npx, npy-2)+ut_tl(npx&
1545 & -1, npy-2)+uc_tl(npx-1, npy-1)-0.25*cosa_u(npx-1, npy-1)*(&
1546 & vt_tl(npx-1, npy)+vt_tl(npx-2, npy)+vt_tl(npx-2, npy-1))))
1547  vt(npx-1, npy-1) = (vc(npx-1, npy-1)-0.25*cosa_v(npx-1, npy-1)&
1548 & *(ut(npx, npy-1)+ut(npx, npy-2)+ut(npx-1, npy-2)+uc(npx-1, &
1549 & npy-1)-0.25*cosa_u(npx-1, npy-1)*(vt(npx-1, npy)+vt(npx-2, &
1550 & npy)+vt(npx-2, npy-1))))*damp
1551  END IF
1552  IF (nw_corner) THEN
1553  damp = 1./(1.-0.0625*cosa_u(2, npy)*cosa_v(1, npy+1))
1554  ut_tl(2, npy) = damp*(uc_tl(2, npy)-0.25*cosa_u(2, npy)*(vt_tl&
1555 & (1, npy)+vt_tl(2, npy)+vt_tl(2, npy+1)+vc_tl(1, npy+1)-0.25*&
1556 & cosa_v(1, npy+1)*(ut_tl(1, npy)+ut_tl(1, npy+1)+ut_tl(2, npy&
1557 & +1))))
1558  ut(2, npy) = (uc(2, npy)-0.25*cosa_u(2, npy)*(vt(1, npy)+vt(2&
1559 & , npy)+vt(2, npy+1)+vc(1, npy+1)-0.25*cosa_v(1, npy+1)*(ut(1&
1560 & , npy)+ut(1, npy+1)+ut(2, npy+1))))*damp
1561  damp = 1./(1.-0.0625*cosa_u(0, npy-1)*cosa_v(0, npy-1))
1562  vt_tl(0, npy-1) = damp*(vc_tl(0, npy-1)-0.25*cosa_v(0, npy-1)*&
1563 & (ut_tl(1, npy-1)+ut_tl(1, npy-2)+ut_tl(0, npy-2)+uc_tl(0, &
1564 & npy-1)-0.25*cosa_u(0, npy-1)*(vt_tl(0, npy)+vt_tl(-1, npy)+&
1565 & vt_tl(-1, npy-1))))
1566  vt(0, npy-1) = (vc(0, npy-1)-0.25*cosa_v(0, npy-1)*(ut(1, npy-&
1567 & 1)+ut(1, npy-2)+ut(0, npy-2)+uc(0, npy-1)-0.25*cosa_u(0, npy&
1568 & -1)*(vt(0, npy)+vt(-1, npy)+vt(-1, npy-1))))*damp
1569  damp = 1./(1.-0.0625*cosa_u(2, npy-1)*cosa_v(1, npy-1))
1570  ut_tl(2, npy-1) = damp*(uc_tl(2, npy-1)-0.25*cosa_u(2, npy-1)*&
1571 & (vt_tl(1, npy)+vt_tl(2, npy)+vt_tl(2, npy-1)+vc_tl(1, npy-1)&
1572 & -0.25*cosa_v(1, npy-1)*(ut_tl(1, npy-1)+ut_tl(1, npy-2)+&
1573 & ut_tl(2, npy-2))))
1574  ut(2, npy-1) = (uc(2, npy-1)-0.25*cosa_u(2, npy-1)*(vt(1, npy)&
1575 & +vt(2, npy)+vt(2, npy-1)+vc(1, npy-1)-0.25*cosa_v(1, npy-1)*&
1576 & (ut(1, npy-1)+ut(1, npy-2)+ut(2, npy-2))))*damp
1577  vt_tl(1, npy-1) = damp*(vc_tl(1, npy-1)-0.25*cosa_v(1, npy-1)*&
1578 & (ut_tl(1, npy-1)+ut_tl(1, npy-2)+ut_tl(2, npy-2)+uc_tl(2, &
1579 & npy-1)-0.25*cosa_u(2, npy-1)*(vt_tl(1, npy)+vt_tl(2, npy)+&
1580 & vt_tl(2, npy-1))))
1581  vt(1, npy-1) = (vc(1, npy-1)-0.25*cosa_v(1, npy-1)*(ut(1, npy-&
1582 & 1)+ut(1, npy-2)+ut(2, npy-2)+uc(2, npy-1)-0.25*cosa_u(2, npy&
1583 & -1)*(vt(1, npy)+vt(2, npy)+vt(2, npy-1))))*damp
1584  END IF
1585  END IF
1586  ELSE
1587  ut_tl = 0.0
1588 ! flagstruct%grid_type >= 3
1589  DO j=jsd,jed
1590  DO i=is,ie+1
1591  ut_tl(i, j) = uc_tl(i, j)
1592  ut(i, j) = uc(i, j)
1593  END DO
1594  END DO
1595  vt_tl = 0.0
1596  DO j=js,je+1
1597  DO i=isd,ied
1598  vt_tl(i, j) = vc_tl(i, j)
1599  vt(i, j) = vc(i, j)
1600  END DO
1601  END DO
1602  END IF
1603  DO j=jsd,jed
1604  DO i=is,ie+1
1605  xfx_adv_tl(i, j) = dt*ut_tl(i, j)
1606  xfx_adv(i, j) = dt*ut(i, j)
1607  END DO
1608  END DO
1609  DO j=js,je+1
1610  DO i=isd,ied
1611  yfx_adv_tl(i, j) = dt*vt_tl(i, j)
1612  yfx_adv(i, j) = dt*vt(i, j)
1613  END DO
1614  END DO
1615 ! Explanation of the following code:
1616 ! xfx_adv = dt*ut*dy
1617 ! crx_adv = dt*ut/dx
1618  DO j=jsd,jed
1619 !DEC$ VECTOR ALWAYS
1620  DO i=is,ie+1
1621  IF (xfx_adv(i, j) .GT. 0.) THEN
1622  crx_adv_tl(i, j) = rdxa(i-1, j)*xfx_adv_tl(i, j)
1623  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i-1, j)
1624  xfx_adv_tl(i, j) = dy(i, j)*sin_sg(i-1, j, 3)*xfx_adv_tl(i, j)
1625  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i-1, j, 3)
1626  ELSE
1627  crx_adv_tl(i, j) = rdxa(i, j)*xfx_adv_tl(i, j)
1628  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i, j)
1629  xfx_adv_tl(i, j) = dy(i, j)*sin_sg(i, j, 1)*xfx_adv_tl(i, j)
1630  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i, j, 1)
1631  END IF
1632  END DO
1633  END DO
1634  DO j=js,je+1
1635 !DEC$ VECTOR ALWAYS
1636  DO i=isd,ied
1637  IF (yfx_adv(i, j) .GT. 0.) THEN
1638  cry_adv_tl(i, j) = rdya(i, j-1)*yfx_adv_tl(i, j)
1639  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j-1)
1640  yfx_adv_tl(i, j) = dx(i, j)*sin_sg(i, j-1, 4)*yfx_adv_tl(i, j)
1641  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j-1, 4)
1642  ELSE
1643  cry_adv_tl(i, j) = rdya(i, j)*yfx_adv_tl(i, j)
1644  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j)
1645  yfx_adv_tl(i, j) = dx(i, j)*sin_sg(i, j, 2)*yfx_adv_tl(i, j)
1646  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j, 2)
1647  END IF
1648  END DO
1649  END DO
1650  ra_x_tl = 0.0
1651  DO j=jsd,jed
1652  DO i=is,ie
1653  ra_x_tl(i, j) = xfx_adv_tl(i, j) - xfx_adv_tl(i+1, j)
1654  ra_x(i, j) = area(i, j) + (xfx_adv(i, j)-xfx_adv(i+1, j))
1655  END DO
1656  END DO
1657  ra_y_tl = 0.0
1658  DO j=js,je
1659  DO i=isd,ied
1660  ra_y_tl(i, j) = yfx_adv_tl(i, j) - yfx_adv_tl(i, j+1)
1661  ra_y(i, j) = area(i, j) + (yfx_adv(i, j)-yfx_adv(i, j+1))
1662  END DO
1663  END DO
1664  IF (hord_dp .EQ. hord_dp_pert .AND. (.NOT.split_damp)) THEN
1665  fy_tl = 0.0
1666  fx_tl = 0.0
1667  CALL fv_tp_2d_tlm(delp, delp_tl, crx_adv, crx_adv_tl, cry_adv, &
1668 & cry_adv_tl, npx, npy, hord_dp, fx, fx_tl, fy, fy_tl&
1669 & , xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1670 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, nord=&
1671 & nord_v, damp_c=damp_v)
1672  ELSE
1673  fy_tl = 0.0
1674  fx_tl = 0.0
1675  CALL fv_tp_2d_tlm(delp, delp_tl, crx_adv, crx_adv_tl, cry_adv, &
1676 & cry_adv_tl, npx, npy, hord_dp_pert, fx, fx_tl, fy, &
1677 & fy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1678 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, nord=&
1679 & nord_v_pert, damp_c=damp_v_pert)
1680  call fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy, &
1681  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, nord=nord_v, damp_c=damp_v)
1682  END IF
1683 ! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>>
1684  DO j=jsd,jed
1685  DO i=is,ie+1
1686  cx_tl(i, j) = cx_tl(i, j) + crx_adv_tl(i, j)
1687  cx(i, j) = cx(i, j) + crx_adv(i, j)
1688  END DO
1689  END DO
1690  DO j=js,je
1691  DO i=is,ie+1
1692  xflux_tl(i, j) = xflux_tl(i, j) + fx_tl(i, j)
1693  xflux(i, j) = xflux(i, j) + fx(i, j)
1694  END DO
1695  END DO
1696  DO j=js,je+1
1697  DO i=isd,ied
1698  cy_tl(i, j) = cy_tl(i, j) + cry_adv_tl(i, j)
1699  cy(i, j) = cy(i, j) + cry_adv(i, j)
1700  END DO
1701  DO i=is,ie
1702  yflux_tl(i, j) = yflux_tl(i, j) + fy_tl(i, j)
1703  yflux(i, j) = yflux(i, j) + fy(i, j)
1704  END DO
1705  END DO
1706  DO j=js,je
1707  DO i=is,ie
1708  heat_source_tl(i, j) = 0.0
1709  heat_source(i, j) = 0.
1710  END DO
1711  END DO
1712  IF (.NOT.hydrostatic) THEN
1713  IF (damp_w .GT. 1.e-5) THEN
1714  IF (dt .GE. 0.) THEN
1715  abs0 = dt
1716  ELSE
1717  abs0 = -dt
1718  END IF
1719  dd8 = kgb*abs0
1720  pwx1 = damp_w*gridstruct%da_min_c
1721  pwy1 = nord_w + 1
1722  damp4 = pwx1**pwy1
1723  fy2_tl = 0.0
1724  fx2_tl = 0.0
1725  wk_tl = 0.0
1726  CALL del6_vt_flux_tlm(nord_w, npx, npy, damp4, w, w_tl, wk, &
1727 & wk_tl, fx2, fx2_tl, fy2, fy2_tl, gridstruct, bd)
1728  dw_tl = 0.0
1729  DO j=js,je
1730  DO i=is,ie
1731  dw_tl(i, j) = rarea(i, j)*(fx2_tl(i, j)-fx2_tl(i+1, j)+&
1732 & fy2_tl(i, j)-fy2_tl(i, j+1))
1733  dw(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
1734 & rarea(i, j)
1735 ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw
1736 ! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j))
1737  heat_source_tl(i, j) = -(dw_tl(i, j)*(w(i, j)+0.5*dw(i, j)))&
1738 & - dw(i, j)*(w_tl(i, j)+0.5*dw_tl(i, j))
1739  heat_source(i, j) = dd8 - dw(i, j)*(w(i, j)+0.5*dw(i, j))
1740  END DO
1741  END DO
1742  ELSE
1743  dw_tl = 0.0
1744  wk_tl = 0.0
1745  END IF
1746  IF (hord_vt .EQ. hord_vt_pert) THEN
1747  gy_tl = 0.0
1748  gx_tl = 0.0
1749  CALL fv_tp_2d_tlm(w, w_tl, crx_adv, crx_adv_tl, cry_adv, &
1750 & cry_adv_tl, npx, npy, hord_vt, gx, gx_tl, gy, &
1751 & gy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1752 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, mfx&
1753 & =fx, mfx_tl=fx_tl, mfy=fy, mfy_tl=fy_tl)
1754  ELSE
1755  gy_tl = 0.0
1756  gx_tl = 0.0
1757  CALL fv_tp_2d_tlm(w, w_tl, crx_adv, crx_adv_tl, cry_adv, &
1758 & cry_adv_tl, npx, npy, hord_vt_pert, gx, gx_tl, gy, &
1759 & gy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1760 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, mfx=fx&
1761 & , mfx_tl=fx_tl, mfy=fy, mfy_tl=fy_tl)
1762  call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, gx, gy, xfx_adv, yfx_adv, &
1763  gridstruct, bd, ra_x, ra_y, mfx=fx, mfy=fy)
1764  END IF
1765  DO j=js,je
1766  DO i=is,ie
1767  w_tl(i, j) = delp_tl(i, j)*w(i, j) + delp(i, j)*w_tl(i, j) + &
1768 & rarea(i, j)*(gx_tl(i, j)-gx_tl(i+1, j)+gy_tl(i, j)-gy_tl(i, &
1769 & j+1))
1770  w(i, j) = delp(i, j)*w(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j)-&
1771 & gy(i, j+1)))*rarea(i, j)
1772  END DO
1773  END DO
1774  ELSE
1775  gx_tl = 0.0
1776  gy_tl = 0.0
1777  dw_tl = 0.0
1778  wk_tl = 0.0
1779  END IF
1780 ! if ( inline_q .and. zvir>0.01 ) then
1781 ! do j=jsd,jed
1782 ! do i=isd,ied
1783 ! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum))
1784 ! enddo
1785 ! enddo
1786 ! endif
1787  IF (hord_tm .EQ. hord_tm_pert .AND. (.NOT.split_damp)) THEN
1788  CALL fv_tp_2d_tlm(pt, pt_tl, crx_adv, crx_adv_tl, cry_adv, &
1789 & cry_adv_tl, npx, npy, hord_tm, gx, gx_tl, gy, gy_tl&
1790 & , xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1791 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, mfx=&
1792 & fx, mfx_tl=fx_tl, mfy=fy, mfy_tl=fy_tl, mass=delp, &
1793 & mass_tl=delp_tl, nord=nord_t, damp_c=damp_t)
1794  ELSE
1795  CALL fv_tp_2d_tlm(pt, pt_tl, crx_adv, crx_adv_tl, cry_adv, &
1796 & cry_adv_tl, npx, npy, hord_tm_pert, gx, gx_tl, gy, &
1797 & gy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
1798 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, mfx=fx, &
1799 & mfx_tl=fx_tl, mfy=fy, mfy_tl=fy_tl, mass=delp, mass_tl&
1800 & =delp_tl, nord=nord_t_pert, damp_c=damp_t_pert)
1801  call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, gx, gy, &
1802  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, &
1803  mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
1804  END IF
1805  IF (inline_q) THEN
1806  DO j=js,je
1807  DO i=is,ie
1808  wk_tl(i, j) = delp_tl(i, j)
1809  wk(i, j) = delp(i, j)
1810  delp_tl(i, j) = wk_tl(i, j) + rarea(i, j)*(fx_tl(i, j)-fx_tl(i&
1811 & +1, j)+fy_tl(i, j)-fy_tl(i, j+1))
1812  delp(i, j) = wk(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
1813 & +1)))*rarea(i, j)
1814  pt_tl(i, j) = ((pt_tl(i, j)*wk(i, j)+pt(i, j)*wk_tl(i, j)+&
1815 & rarea(i, j)*(gx_tl(i, j)-gx_tl(i+1, j)+gy_tl(i, j)-gy_tl(i, &
1816 & j+1)))*delp(i, j)-(pt(i, j)*wk(i, j)+(gx(i, j)-gx(i+1, j)+(&
1817 & gy(i, j)-gy(i, j+1)))*rarea(i, j))*delp_tl(i, j))/delp(i, j)&
1818 & **2
1819  pt(i, j) = (pt(i, j)*wk(i, j)+(gx(i, j)-gx(i+1, j)+(gy(i, j)-&
1820 & gy(i, j+1)))*rarea(i, j))/delp(i, j)
1821  END DO
1822  END DO
1823  DO iq=1,nq
1824  IF (hord_tr .EQ. hord_tr_pert) THEN
1825  CALL fv_tp_2d_tlm(q(isd:ied, jsd:jed, k, iq), q_tl(isd:ied&
1826 & , jsd:jed, k, iq), crx_adv, crx_adv_tl, cry_adv&
1827 & , cry_adv_tl, npx, npy, hord_tr, gx, gx_tl, gy&
1828 & , gy_tl, xfx_adv, xfx_adv_tl, yfx_adv, &
1829 & yfx_adv_tl, gridstruct, bd, ra_x, ra_x_tl, ra_y&
1830 & , ra_y_tl, mfx=fx, mfx_tl=fx_tl, mfy=fy, mfy_tl&
1831 & =fy_tl, mass=delp, mass_tl=delp_tl, nord=nord_t&
1832 & , damp_c=damp_t)
1833  ELSE
1834  CALL fv_tp_2d_tlm(q(isd:ied, jsd:jed, k, iq), q_tl(isd:ied, &
1835 & jsd:jed, k, iq), crx_adv, crx_adv_tl, cry_adv, &
1836 & cry_adv_tl, npx, npy, hord_tr_pert, gx, gx_tl, gy&
1837 & , gy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl&
1838 & , gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, &
1839 & mfx=fx, mfx_tl=fx_tl, mfy=fy, mfy_tl=fy_tl, mass=&
1840 & delp, mass_tl=delp_tl, nord=nord_t_pert, damp_c=&
1841 & damp_t_pert)
1842  call fv_tp_2d(q(isd:ied,jsd:jed,k,iq), crx_adv,cry_adv, npx, npy, hord_tr, gx, gy, &
1843  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, &
1844  mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
1845  END IF
1846  DO j=js,je
1847  DO i=is,ie
1848  q_tl(i, j, k, iq) = ((q_tl(i, j, k, iq)*wk(i, j)+q(i, j, k, &
1849 & iq)*wk_tl(i, j)+rarea(i, j)*(gx_tl(i, j)-gx_tl(i+1, j)+&
1850 & gy_tl(i, j)-gy_tl(i, j+1)))*delp(i, j)-(q(i, j, k, iq)*wk(&
1851 & i, j)+(gx(i, j)-gx(i+1, j)+(gy(i, j)-gy(i, j+1)))*rarea(i&
1852 & , j))*delp_tl(i, j))/delp(i, j)**2
1853  q(i, j, k, iq) = (q(i, j, k, iq)*wk(i, j)+(gx(i, j)-gx(i+1, &
1854 & j)+(gy(i, j)-gy(i, j+1)))*rarea(i, j))/delp(i, j)
1855  END DO
1856  END DO
1857  END DO
1858  ELSE
1859 ! if ( zvir>0.01 ) then
1860 ! do j=js,je
1861 ! do i=is,ie
1862 ! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum))
1863 ! enddo
1864 ! enddo
1865 ! endif
1866  DO j=js,je
1867  DO i=is,ie
1868  pt_tl(i, j) = pt_tl(i, j)*delp(i, j) + pt(i, j)*delp_tl(i, j) &
1869 & + rarea(i, j)*(gx_tl(i, j)-gx_tl(i+1, j)+gy_tl(i, j)-gy_tl(i&
1870 & , j+1))
1871  pt(i, j) = pt(i, j)*delp(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j&
1872 & )-gy(i, j+1)))*rarea(i, j)
1873  delp_tl(i, j) = delp_tl(i, j) + rarea(i, j)*(fx_tl(i, j)-fx_tl&
1874 & (i+1, j)+fy_tl(i, j)-fy_tl(i, j+1))
1875  delp(i, j) = delp(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i&
1876 & , j+1)))*rarea(i, j)
1877  pt_tl(i, j) = (pt_tl(i, j)*delp(i, j)-pt(i, j)*delp_tl(i, j))/&
1878 & delp(i, j)**2
1879  pt(i, j) = pt(i, j)/delp(i, j)
1880  END DO
1881  END DO
1882  END IF
1883  IF (fpp%fpp_overload_r4) THEN
1884  DO j=js,je
1885  DO i=is,ie
1886  dpx_tl(i, j) = dpx_tl(i, j) + rarea(i, j)*(fx_tl(i, j)-fx_tl(i&
1887 & +1, j)+fy_tl(i, j)-fy_tl(i, j+1))
1888  dpx(i, j) = dpx(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
1889 & +1)))*rarea(i, j)
1890  END DO
1891  END DO
1892  END IF
1893 !----------------------
1894 ! Kinetic Energy Fluxes
1895 !----------------------
1896 ! Compute B grid contra-variant components for KE:
1897  dt5 = 0.5*dt
1898  dt4 = 0.25*dt
1899  IF (nested) THEN
1900  is2 = is
1901  ie1 = ie + 1
1902  js2 = js
1903  je1 = je + 1
1904  ELSE
1905  IF (2 .LT. is) THEN
1906  is2 = is
1907  ELSE
1908  is2 = 2
1909  END IF
1910  IF (npx - 1 .GT. ie + 1) THEN
1911  ie1 = ie + 1
1912  ELSE
1913  ie1 = npx - 1
1914  END IF
1915  IF (2 .LT. js) THEN
1916  js2 = js
1917  ELSE
1918  js2 = 2
1919  END IF
1920  IF (npy - 1 .GT. je + 1) THEN
1921  je1 = je + 1
1922  ELSE
1923  je1 = npy - 1
1924  END IF
1925  END IF
1926 !!! TO DO: separate versions for nested and for cubed-sphere
1927  IF (flagstruct%grid_type .LT. 3) THEN
1928  IF (nested) THEN
1929  vb_tl = 0.0
1930  DO j=js2,je1
1931  DO i=is2,ie1
1932  vb_tl(i, j) = dt5*rsina(i, j)*(vc_tl(i-1, j)+vc_tl(i, j)-&
1933 & cosa(i, j)*(uc_tl(i, j-1)+uc_tl(i, j)))
1934  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
1935 & cosa(i, j))*rsina(i, j)
1936  END DO
1937  END DO
1938  ELSE
1939  IF (js .EQ. 1) THEN
1940  vb_tl = 0.0
1941  DO i=is,ie+1
1942 ! corner values are incorrect
1943  vb_tl(i, 1) = dt5*(vt_tl(i-1, 1)+vt_tl(i, 1))
1944  vb(i, 1) = dt5*(vt(i-1, 1)+vt(i, 1))
1945  END DO
1946  ELSE
1947  vb_tl = 0.0
1948  END IF
1949  DO j=js2,je1
1950  DO i=is2,ie1
1951  vb_tl(i, j) = dt5*rsina(i, j)*(vc_tl(i-1, j)+vc_tl(i, j)-&
1952 & cosa(i, j)*(uc_tl(i, j-1)+uc_tl(i, j)))
1953  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
1954 & cosa(i, j))*rsina(i, j)
1955  END DO
1956  IF (is .EQ. 1) THEN
1957 ! 2-pt extrapolation from both sides:
1958  vb_tl(1, j) = dt4*(3.*(vt_tl(0, j)+vt_tl(1, j))-vt_tl(-1, j)&
1959 & -vt_tl(2, j))
1960  vb(1, j) = dt4*(-vt(-1, j)+3.*(vt(0, j)+vt(1, j))-vt(2, j))
1961  END IF
1962  IF (ie + 1 .EQ. npx) THEN
1963 ! 2-pt extrapolation from both sides:
1964  vb_tl(npx, j) = dt4*(3.*(vt_tl(npx-1, j)+vt_tl(npx, j))-&
1965 & vt_tl(npx-2, j)-vt_tl(npx+1, j))
1966  vb(npx, j) = dt4*(-vt(npx-2, j)+3.*(vt(npx-1, j)+vt(npx, j))&
1967 & -vt(npx+1, j))
1968  END IF
1969  END DO
1970  IF (je + 1 .EQ. npy) THEN
1971  DO i=is,ie+1
1972 ! corner values are incorrect
1973  vb_tl(i, npy) = dt5*(vt_tl(i-1, npy)+vt_tl(i, npy))
1974  vb(i, npy) = dt5*(vt(i-1, npy)+vt(i, npy))
1975  END DO
1976  END IF
1977  END IF
1978  ELSE
1979  vb_tl = 0.0
1980  DO j=js,je+1
1981  DO i=is,ie+1
1982  vb_tl(i, j) = dt5*(vc_tl(i-1, j)+vc_tl(i, j))
1983  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j))
1984  END DO
1985  END DO
1986  END IF
1987  IF (hord_mt .EQ. hord_mt_pert) THEN
1988  CALL ytp_v_tlm(is, ie, js, je, isd, ied, jsd, jed, vb, vb_tl, u&
1989 & , v, v_tl, ub, ub_tl, hord_mt, gridstruct%dy, &
1990 & gridstruct%rdy, npx, npy, flagstruct%grid_type, nested&
1991 & )
1992  ke_tl = 0.0
1993  ELSE
1994  CALL ytp_v_tlm(is, ie, js, je, isd, ied, jsd, jed, vb, vb_tl, u, v&
1995 & , v_tl, ub, ub_tl, hord_mt_pert, gridstruct%dy, &
1996 & gridstruct%rdy, npx, npy, flagstruct%grid_type, nested)
1997  call ytp_v(is,ie,js,je,isd,ied,jsd,jed, vb, u, v, ub, hord_mt, gridstruct%dy, gridstruct%rdy, &
1998  npx, npy, flagstruct%grid_type, nested)
1999  ke_tl = 0.0
2000  END IF
2001  DO j=js,je+1
2002  DO i=is,ie+1
2003  ke_tl(i, j) = vb_tl(i, j)*ub(i, j) + vb(i, j)*ub_tl(i, j)
2004  ke(i, j) = vb(i, j)*ub(i, j)
2005  END DO
2006  END DO
2007  IF (flagstruct%grid_type .LT. 3) THEN
2008  IF (nested) THEN
2009  DO j=js,je+1
2010  DO i=is2,ie1
2011  ub_tl(i, j) = dt5*rsina(i, j)*(uc_tl(i, j-1)+uc_tl(i, j)-&
2012 & cosa(i, j)*(vc_tl(i-1, j)+vc_tl(i, j)))
2013  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
2014 & cosa(i, j))*rsina(i, j)
2015  END DO
2016  END DO
2017  ELSE
2018  IF (is .EQ. 1) THEN
2019  DO j=js,je+1
2020 ! corner values are incorrect
2021  ub_tl(1, j) = dt5*(ut_tl(1, j-1)+ut_tl(1, j))
2022  ub(1, j) = dt5*(ut(1, j-1)+ut(1, j))
2023  END DO
2024  END IF
2025  DO j=js,je+1
2026  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
2027  DO i=is2,ie1
2028 ! 2-pt extrapolation from both sides:
2029  ub_tl(i, j) = dt4*(3.*(ut_tl(i, j-1)+ut_tl(i, j))-ut_tl(i&
2030 & , j-2)-ut_tl(i, j+1))
2031  ub(i, j) = dt4*(-ut(i, j-2)+3.*(ut(i, j-1)+ut(i, j))-ut(i&
2032 & , j+1))
2033  END DO
2034  ELSE
2035  DO i=is2,ie1
2036  ub_tl(i, j) = dt5*rsina(i, j)*(uc_tl(i, j-1)+uc_tl(i, j)-&
2037 & cosa(i, j)*(vc_tl(i-1, j)+vc_tl(i, j)))
2038  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
2039 & cosa(i, j))*rsina(i, j)
2040  END DO
2041  END IF
2042  END DO
2043  IF (ie + 1 .EQ. npx) THEN
2044  DO j=js,je+1
2045 ! corner values are incorrect
2046  ub_tl(npx, j) = dt5*(ut_tl(npx, j-1)+ut_tl(npx, j))
2047  ub(npx, j) = dt5*(ut(npx, j-1)+ut(npx, j))
2048  END DO
2049  END IF
2050  END IF
2051  ELSE
2052  DO j=js,je+1
2053  DO i=is,ie+1
2054  ub_tl(i, j) = dt5*(uc_tl(i, j-1)+uc_tl(i, j))
2055  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j))
2056  END DO
2057  END DO
2058  END IF
2059  IF (hord_mt .EQ. hord_mt_pert) THEN
2060  CALL xtp_u_tlm(is, ie, js, je, isd, ied, jsd, jed, ub, ub_tl, u&
2061 & , u_tl, v, vb, vb_tl, hord_mt, gridstruct%dx, &
2062 & gridstruct%rdx, npx, npy, flagstruct%grid_type, nested&
2063 & )
2064  ELSE
2065  CALL xtp_u_tlm(is, ie, js, je, isd, ied, jsd, jed, ub, ub_tl, u, &
2066 & u_tl, v, vb, vb_tl, hord_mt_pert, gridstruct%dx, &
2067 & gridstruct%rdx, npx, npy, flagstruct%grid_type, nested)
2068  call xtp_u(is,ie,js,je, isd,ied,jsd,jed, ub, u, v, vb, hord_mt, gridstruct%dx, gridstruct%rdx, &
2069  npx, npy, flagstruct%grid_type, nested)
2070  END IF
2071  DO j=js,je+1
2072  DO i=is,ie+1
2073  ke_tl(i, j) = 0.5*(ke_tl(i, j)+ub_tl(i, j)*vb(i, j)+ub(i, j)*&
2074 & vb_tl(i, j))
2075  ke(i, j) = 0.5*(ke(i, j)+ub(i, j)*vb(i, j))
2076  END DO
2077  END DO
2078 !-----------------------------------------
2079 ! Fix KE at the 4 corners of the face:
2080 !-----------------------------------------
2081  IF (.NOT.nested) THEN
2082  dt6 = dt/6.
2083  IF (sw_corner) THEN
2084  ke_tl(1, 1) = dt6*((ut_tl(1, 1)+ut_tl(1, 0))*u(1, 1)+(ut(1, 1)+&
2085 & ut(1, 0))*u_tl(1, 1)+(vt_tl(1, 1)+vt_tl(0, 1))*v(1, 1)+(vt(1, &
2086 & 1)+vt(0, 1))*v_tl(1, 1)+(ut_tl(1, 1)+vt_tl(1, 1))*u(0, 1)+(ut(&
2087 & 1, 1)+vt(1, 1))*u_tl(0, 1))
2088  ke(1, 1) = dt6*((ut(1, 1)+ut(1, 0))*u(1, 1)+(vt(1, 1)+vt(0, 1))*&
2089 & v(1, 1)+(ut(1, 1)+vt(1, 1))*u(0, 1))
2090  END IF
2091  IF (se_corner) THEN
2092 !i = npx
2093  ke_tl(npx, 1) = dt6*((ut_tl(npx, 1)+ut_tl(npx, 0))*u(npx-1, 1)+(&
2094 & ut(npx, 1)+ut(npx, 0))*u_tl(npx-1, 1)+(vt_tl(npx, 1)+vt_tl(npx&
2095 & -1, 1))*v(npx, 1)+(vt(npx, 1)+vt(npx-1, 1))*v_tl(npx, 1)+(&
2096 & ut_tl(npx, 1)-vt_tl(npx-1, 1))*u(npx, 1)+(ut(npx, 1)-vt(npx-1&
2097 & , 1))*u_tl(npx, 1))
2098  ke(npx, 1) = dt6*((ut(npx, 1)+ut(npx, 0))*u(npx-1, 1)+(vt(npx, 1&
2099 & )+vt(npx-1, 1))*v(npx, 1)+(ut(npx, 1)-vt(npx-1, 1))*u(npx, 1))
2100  END IF
2101  IF (ne_corner) THEN
2102 !i = npx; j = npy
2103  ke_tl(npx, npy) = dt6*((ut_tl(npx, npy)+ut_tl(npx, npy-1))*u(npx&
2104 & -1, npy)+(ut(npx, npy)+ut(npx, npy-1))*u_tl(npx-1, npy)+(vt_tl&
2105 & (npx, npy)+vt_tl(npx-1, npy))*v(npx, npy-1)+(vt(npx, npy)+vt(&
2106 & npx-1, npy))*v_tl(npx, npy-1)+(ut_tl(npx, npy-1)+vt_tl(npx-1, &
2107 & npy))*u(npx, npy)+(ut(npx, npy-1)+vt(npx-1, npy))*u_tl(npx, &
2108 & npy))
2109  ke(npx, npy) = dt6*((ut(npx, npy)+ut(npx, npy-1))*u(npx-1, npy)+&
2110 & (vt(npx, npy)+vt(npx-1, npy))*v(npx, npy-1)+(ut(npx, npy-1)+vt&
2111 & (npx-1, npy))*u(npx, npy))
2112  END IF
2113  IF (nw_corner) THEN
2114 !j = npy
2115  ke_tl(1, npy) = dt6*((ut_tl(1, npy)+ut_tl(1, npy-1))*u(1, npy)+(&
2116 & ut(1, npy)+ut(1, npy-1))*u_tl(1, npy)+(vt_tl(1, npy)+vt_tl(0, &
2117 & npy))*v(1, npy-1)+(vt(1, npy)+vt(0, npy))*v_tl(1, npy-1)+(&
2118 & ut_tl(1, npy-1)-vt_tl(1, npy))*u(0, npy)+(ut(1, npy-1)-vt(1, &
2119 & npy))*u_tl(0, npy))
2120  ke(1, npy) = dt6*((ut(1, npy)+ut(1, npy-1))*u(1, npy)+(vt(1, npy&
2121 & )+vt(0, npy))*v(1, npy-1)+(ut(1, npy-1)-vt(1, npy))*u(0, npy))
2122  END IF
2123  END IF
2124 ! Compute vorticity:
2125  DO j=jsd,jed+1
2126  DO i=isd,ied
2127  vt_tl(i, j) = dx(i, j)*u_tl(i, j)
2128  vt(i, j) = u(i, j)*dx(i, j)
2129  END DO
2130  END DO
2131  DO j=jsd,jed
2132  DO i=isd,ied+1
2133  ut_tl(i, j) = dy(i, j)*v_tl(i, j)
2134  ut(i, j) = v(i, j)*dy(i, j)
2135  END DO
2136  END DO
2137 ! wk is "volume-mean" relative vorticity
2138  DO j=jsd,jed
2139  DO i=isd,ied
2140  wk_tl(i, j) = rarea(i, j)*(vt_tl(i, j)-vt_tl(i, j+1)+ut_tl(i+1, &
2141 & j)-ut_tl(i, j))
2142  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i+1, j)-ut(i, j)&
2143 & ))
2144  END DO
2145  END DO
2146  IF (.NOT.hydrostatic) THEN
2147  IF (.NOT.flagstruct%do_f3d) THEN
2148  DO j=js,je
2149  DO i=is,ie
2150  w_tl(i, j) = (w_tl(i, j)*delp(i, j)-w(i, j)*delp_tl(i, j))/&
2151 & delp(i, j)**2
2152  w(i, j) = w(i, j)/delp(i, j)
2153  END DO
2154  END DO
2155  END IF
2156  IF (damp_w .GT. 1.e-5) THEN
2157  DO j=js,je
2158  DO i=is,ie
2159  w_tl(i, j) = w_tl(i, j) + dw_tl(i, j)
2160  w(i, j) = w(i, j) + dw(i, j)
2161  END DO
2162  END DO
2163  END IF
2164  END IF
2165 !-----------------------------
2166 ! Compute divergence damping
2167 !-----------------------------
2168 !! damp = dddmp * da_min_c
2169 !
2170 ! if ( nord==0 ) then
2171 !! area ~ dxb*dyb*sin(alpha)
2172 !
2173 ! if (nested) then
2174 !
2175 ! do j=js,je+1
2176 ! do i=is-1,ie+1
2177 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
2178 ! *dyc(i,j)*sina_v(i,j)
2179 ! enddo
2180 ! enddo
2181 !
2182 ! do j=js-1,je+1
2183 ! do i=is2,ie1
2184 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
2185 ! *dxc(i,j)*sina_u(i,j)
2186 ! enddo
2187 ! enddo
2188 !
2189 ! else
2190 ! do j=js,je+1
2191 !
2192 ! if ( (j==1 .or. j==npy) ) then
2193 ! do i=is-1,ie+1
2194 ! if (vc(i,j) > 0) then
2195 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4)
2196 ! else
2197 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2)
2198 ! end if
2199 ! enddo
2200 ! else
2201 ! do i=is-1,ie+1
2202 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
2203 ! *dyc(i,j)*sina_v(i,j)
2204 ! enddo
2205 ! endif
2206 ! enddo
2207 !
2208 ! do j=js-1,je+1
2209 ! do i=is2,ie1
2210 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
2211 ! *dxc(i,j)*sina_u(i,j)
2212 ! enddo
2213 ! if ( is == 1 ) then
2214 ! if (uc(1,j) > 0) then
2215 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3)
2216 ! else
2217 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1)
2218 ! end if
2219 ! end if
2220 ! if ( (ie+1)==npx ) then
2221 ! if (uc(npx,j) > 0) then
2222 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
2223 ! sin_sg(npx-1,j,3)
2224 ! else
2225 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
2226 ! sin_sg(npx,j,1)
2227 ! end if
2228 ! end if
2229 ! enddo
2230 ! endif
2231 !
2232 ! do j=js,je+1
2233 ! do i=is,ie+1
2234 ! delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j)
2235 ! enddo
2236 ! enddo
2237 !
2238 !! Remove the extra term at the corners:
2239 ! if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
2240 ! if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
2241 ! if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy)
2242 ! if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
2243 !
2244 ! do j=js,je+1
2245 ! do i=is,ie+1
2246 ! delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j)
2247 ! damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt)))
2248 ! vort(i,j) = damp*delpc(i,j)
2249 ! ke(i,j) = ke(i,j) + vort(i,j)
2250 ! enddo
2251 ! enddo
2252 ! else
2253 !!--------------------------
2254 !! Higher order divg damping
2255 !!--------------------------
2256 ! do j=js,je+1
2257 ! do i=is,ie+1
2258 !! Save divergence for external mode filter
2259 ! delpc(i,j) = divg_d(i,j)
2260 ! enddo
2261 ! enddo
2262 !
2263 ! n2 = nord + 1 ! N > 1
2264 ! do n=1,nord
2265 ! nt = nord-n
2266 !
2267 ! fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. &
2268 ! ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) &
2269 ! .and. .not. nested
2270 !
2271 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.)
2272 ! do j=js-nt,je+1+nt
2273 ! do i=is-1-nt,ie+1+nt
2274 ! vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j)
2275 ! enddo
2276 ! enddo
2277 !
2278 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.)
2279 ! do j=js-1-nt,je+1+nt
2280 ! do i=is-nt,ie+1+nt
2281 ! uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j)
2282 ! enddo
2283 ! enddo
2284 !
2285 ! if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.)
2286 ! do j=js-nt,je+1+nt
2287 ! do i=is-nt,ie+1+nt
2288 ! divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j)
2289 ! enddo
2290 ! enddo
2291 !
2292 !! Remove the extra term at the corners:
2293 ! if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
2294 ! if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
2295 ! if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy)
2296 ! if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
2297 !
2298 ! if ( .not. gridstruct%stretched_grid ) then
2299 ! do j=js-nt,je+1+nt
2300 ! do i=is-nt,ie+1+nt
2301 ! divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j)
2302 ! enddo
2303 ! enddo
2304 ! endif
2305 !
2306 ! enddo ! n-loop
2307 !
2308 ! if ( dddmp<1.E-5) then
2309 ! vort(:,:) = 0.
2310 ! else
2311 ! if ( flagstruct%grid_type < 3 ) then
2312 !! Interpolate relative vort to cell corners
2313 ! call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.)
2314 ! do j=js,je+1
2315 ! do i=is,ie+1
2316 !! The following is an approxi form of Smagorinsky diffusion
2317 ! vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2)
2318 ! enddo
2319 ! enddo
2320 ! else ! Correct form: works only for doubly preiodic domain
2321 ! call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng)
2322 ! endif
2323 ! endif
2324 !
2325 ! if (gridstruct%stretched_grid ) then
2326 !! Stretched grid with variable damping ~ area
2327 ! dd8 = gridstruct%da_min * d4_bg**n2
2328 ! else
2329 ! dd8 = ( gridstruct%da_min_c*d4_bg )**n2
2330 ! endif
2331 !
2332 ! do j=js,je+1
2333 ! do i=is,ie+1
2334 ! damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2
2335 ! vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j)
2336 ! ke(i,j) = ke(i,j) + vort(i,j)
2337 ! enddo
2338 ! enddo
2339 !
2340 ! endif
2341  IF (.NOT.split_damp) THEN
2342  CALL compute_divergence_damping_tlm(nord, d2_bg, d4_bg, dddmp, &
2343 & dt, vort, vort_tl, ptc, ptc_tl, &
2344 & delpc, delpc_tl, ke, ke_tl, u, &
2345 & u_tl, v, v_tl, uc, uc_tl, vc, &
2346 & vc_tl, ua, ua_tl, va, va_tl, &
2347 & divg_d, divg_d_tl, wk, wk_tl, &
2348 & gridstruct, flagstruct, bd)
2349  ELSE
2350  wk_tj = wk
2351  vort_tj = vort
2352  delpc_tj = delpc
2353  ptc_tj = ptc
2354  ke_tj = ke
2355  vc_tj = vc
2356  uc_tj = uc
2357  divg_d_tj = divg_d
2358  CALL compute_divergence_damping_tlm(nord_pert, d2_bg_pert, &
2359 & d4_bg_pert, dddmp_pert, dt, vort_tj, &
2360 & vort_tl, ptc_tj, ptc_tl, delpc_tj, &
2361 & delpc_tl, ke_tj, ke_tl, u, u_tl, v, &
2362 & v_tl, uc_tj, uc_tl, vc_tj, vc_tl, ua, &
2363 & ua_tl, va, va_tl, divg_d_tj, divg_d_tl&
2364 & , wk_tj, wk_tl, gridstruct, flagstruct&
2365 & , bd)
2366  call compute_divergence_damping( nord,d2_bg,d4_bg,dddmp,dt, &
2367  vort,ptc,delpc,ke,u,v,uc,vc,ua,va,divg_d,wk, &
2368  gridstruct, flagstruct, bd)
2369  END IF
2370  IF (d_con .GT. 1.e-5) THEN
2371  DO j=js,je+1
2372  DO i=is,ie
2373  ub_tl(i, j) = vort_tl(i, j) - vort_tl(i+1, j)
2374  ub(i, j) = vort(i, j) - vort(i+1, j)
2375  END DO
2376  END DO
2377  DO j=js,je
2378  DO i=is,ie+1
2379  vb_tl(i, j) = vort_tl(i, j) - vort_tl(i, j+1)
2380  vb(i, j) = vort(i, j) - vort(i, j+1)
2381  END DO
2382  END DO
2383  END IF
2384 ! Vorticity transport
2385  IF (hydrostatic) THEN
2386  DO j=jsd,jed
2387  DO i=isd,ied
2388  vort_tl(i, j) = wk_tl(i, j)
2389  vort(i, j) = wk(i, j) + f0(i, j)
2390  END DO
2391  END DO
2392  ELSE IF (flagstruct%do_f3d) THEN
2393  DO j=jsd,jed
2394  DO i=isd,ied
2395  vort_tl(i, j) = wk_tl(i, j) + f0(i, j)*z_rat_tl(i, j)
2396  vort(i, j) = wk(i, j) + f0(i, j)*z_rat(i, j)
2397  END DO
2398  END DO
2399  ELSE
2400  DO j=jsd,jed
2401  DO i=isd,ied
2402  vort_tl(i, j) = wk_tl(i, j)
2403  vort(i, j) = wk(i, j) + f0(i, j)
2404  END DO
2405  END DO
2406  END IF
2407  IF (hord_vt .EQ. hord_vt_pert) THEN
2408  CALL fv_tp_2d_tlm(vort, vort_tl, crx_adv, crx_adv_tl, cry_adv, &
2409 & cry_adv_tl, npx, npy, hord_vt, fx, fx_tl, fy, fy_tl&
2410 & , xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
2411 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl)
2412  ELSE
2413  CALL fv_tp_2d_tlm(vort, vort_tl, crx_adv, crx_adv_tl, cry_adv, &
2414 & cry_adv_tl, npx, npy, hord_vt_pert, fx, fx_tl, fy, &
2415 & fy_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, &
2416 & gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl)
2417  call fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy, &
2418  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y)
2419  END IF
2420  DO j=js,je+1
2421  DO i=is,ie
2422  u_tl(i, j) = vt_tl(i, j) + ke_tl(i, j) - ke_tl(i+1, j) + fy_tl(i&
2423 & , j)
2424  u(i, j) = vt(i, j) + (ke(i, j)-ke(i+1, j)) + fy(i, j)
2425  END DO
2426  END DO
2427  DO j=js,je
2428  DO i=is,ie+1
2429  v_tl(i, j) = ut_tl(i, j) + ke_tl(i, j) - ke_tl(i, j+1) - fx_tl(i&
2430 & , j)
2431  v(i, j) = ut(i, j) + (ke(i, j)-ke(i, j+1)) - fx(i, j)
2432  END DO
2433  END DO
2434 !--------------------------------------------------------
2435 ! damping applied to relative vorticity (wk):
2436  IF (damp_v .GT. 1.e-5) THEN
2437  pwx1 = damp_v*gridstruct%da_min_c
2438  pwy1 = nord_v + 1
2439  damp4 = pwx1**pwy1
2440  call del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, gridstruct, bd)
2441  END IF
2442  IF (damp_v_pert .GT. 1.e-5) THEN
2443  wk_tj = wk
2444  vort_tj = vort
2445  ut_tj = ut
2446  vt_tj = vt
2447  pwx1 = damp_v_pert*gridstruct%da_min_c
2448  pwy1 = nord_v_pert + 1
2449  damp4 = pwx1**pwy1
2450  CALL del6_vt_flux_tlm(nord_v_pert, npx, npy, damp4, wk_tj, wk_tl, vort_tj, &
2451 & vort_tl, ut_tj, ut_tl, vt_tj, vt_tl, gridstruct, bd)
2452  END IF
2453  IF (d_con .GT. 1.e-5) THEN
2454  DO j=js,je+1
2455  DO i=is,ie
2456  ub_tl(i, j) = rdx(i, j)*(ub_tl(i, j)+vt_tl(i, j))
2457  ub(i, j) = (ub(i, j)+vt(i, j))*rdx(i, j)
2458  fy_tl(i, j) = rdx(i, j)*u_tl(i, j)
2459  fy(i, j) = u(i, j)*rdx(i, j)
2460  gy_tl(i, j) = fy_tl(i, j)*ub(i, j) + fy(i, j)*ub_tl(i, j)
2461  gy(i, j) = fy(i, j)*ub(i, j)
2462  END DO
2463  END DO
2464  DO j=js,je
2465  DO i=is,ie+1
2466  vb_tl(i, j) = rdy(i, j)*(vb_tl(i, j)-ut_tl(i, j))
2467  vb(i, j) = (vb(i, j)-ut(i, j))*rdy(i, j)
2468  fx_tl(i, j) = rdy(i, j)*v_tl(i, j)
2469  fx(i, j) = v(i, j)*rdy(i, j)
2470  gx_tl(i, j) = fx_tl(i, j)*vb(i, j) + fx(i, j)*vb_tl(i, j)
2471  gx(i, j) = fx(i, j)*vb(i, j)
2472  END DO
2473  END DO
2474 !----------------------------------
2475 ! Heating due to damping:
2476 !----------------------------------
2477  damp = 0.25*d_con
2478  DO j=js,je
2479  DO i=is,ie
2480  u2_tl = fy_tl(i, j) + fy_tl(i, j+1)
2481  u2 = fy(i, j) + fy(i, j+1)
2482  du2_tl = ub_tl(i, j) + ub_tl(i, j+1)
2483  du2 = ub(i, j) + ub(i, j+1)
2484  v2_tl = fx_tl(i, j) + fx_tl(i+1, j)
2485  v2 = fx(i, j) + fx(i+1, j)
2486  dv2_tl = vb_tl(i, j) + vb_tl(i+1, j)
2487  dv2 = vb(i, j) + vb(i+1, j)
2488 ! Total energy conserving:
2489 ! Convert lost KE due to divergence damping to "heat"
2490  heat_source_tl(i, j) = delp_tl(i, j)*(heat_source(i, j)-damp*&
2491 & rsin2(i, j)*(ub(i, j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j&
2492 & )**2+2.*(gy(i, j)+gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, &
2493 & j)*(u2*dv2+v2*du2+du2*dv2))) + delp(i, j)*(heat_source_tl(i&
2494 & , j)-damp*rsin2(i, j)*(2*ub(i, j)*ub_tl(i, j)+2*ub(i, j+1)*&
2495 & ub_tl(i, j+1)+2*vb(i, j)*vb_tl(i, j)+2*vb(i+1, j)*vb_tl(i+1&
2496 & , j)+2.*(gy_tl(i, j)+gy_tl(i, j+1)+gx_tl(i, j)+gx_tl(i+1, j)&
2497 & )-cosa_s(i, j)*(u2_tl*dv2+u2*dv2_tl+v2_tl*du2+v2*du2_tl+&
2498 & du2_tl*dv2+du2*dv2_tl)))
2499  heat_source(i, j) = delp(i, j)*(heat_source(i, j)-damp*rsin2(i&
2500 & , j)*(ub(i, j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j)**2+2.&
2501 & *(gy(i, j)+gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, j)*(u2*&
2502 & dv2+v2*du2+du2*dv2)))
2503  END DO
2504  END DO
2505  END IF
2506 ! Add diffusive fluxes to the momentum equation:
2507  IF (damp_v .GT. 1.e-5) THEN
2508  DO j=js,je+1
2509  DO i=is,ie
2510  u(i, j) = u(i, j) + vt(i, j)
2511  END DO
2512  END DO
2513  DO j=js,je
2514  DO i=is,ie+1
2515  v(i, j) = v(i, j) - ut(i, j)
2516  END DO
2517  END DO
2518  END IF
2519  IF (damp_v_pert .GT. 1.e-5) THEN
2520  DO j=js,je+1
2521  DO i=is,ie
2522  u_tl(i, j) = u_tl(i, j) + vt_tl(i, j)
2523  END DO
2524  END DO
2525  DO j=js,je
2526  DO i=is,ie+1
2527  v_tl(i, j) = v_tl(i, j) - ut_tl(i, j)
2528  END DO
2529  END DO
2530  END IF
2531  END SUBROUTINE d_sw_tlm
2532 ! d_sw :: D-Grid Shallow Water Routine
2533  SUBROUTINE d_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d&
2534 & , xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, &
2535 & z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, &
2536 & dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, &
2537 & nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, &
2538 & hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert&
2539 & , hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, &
2540 & nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, &
2541 & d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
2542  IMPLICIT NONE
2543  INTEGER, INTENT(IN) :: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
2544 ! nord=1 divergence damping; (del-4) or 3 (del-8)
2545  INTEGER, INTENT(IN) :: nord
2546 ! vorticity damping
2547  INTEGER, INTENT(IN) :: nord_v
2548 ! vertical velocity
2549  INTEGER, INTENT(IN) :: nord_w
2550 ! pt
2551  INTEGER, INTENT(IN) :: nord_t
2552  INTEGER, INTENT(IN) :: sphum, nq, k, km
2553  REAL, INTENT(IN) :: dt, dddmp, d2_bg, d4_bg, d_con
2554  REAL, INTENT(IN) :: zvir
2555  REAL, INTENT(IN) :: damp_v, damp_w, damp_t, kgb
2556  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
2557  INTEGER, INTENT(IN) :: hord_tr_pert, hord_mt_pert, hord_vt_pert, &
2558 & hord_tm_pert, hord_dp_pert, nord_pert, nord_v_pert, nord_w_pert, &
2559 & nord_t_pert
2560  LOGICAL, INTENT(IN) :: split_damp
2561  REAL, INTENT(IN) :: dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert&
2562 & , damp_w_pert, damp_t_pert
2563 ! divergence
2564  REAL, INTENT(INOUT) :: divg_d(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
2565  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: z_rat
2566  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
2567 & , pt, ua, va
2568  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
2569  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
2570 & q_con
2571  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
2572 & , vc
2573  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
2574 & , uc
2575  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
2576  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
2577 & , ptc
2578  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(OUT) :: &
2579 & heat_source
2580  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
2581 & dpx
2582 ! The flux capacitors:
2583  REAL, INTENT(INOUT) :: xflux(bd%is:bd%ie+1, bd%js:bd%je)
2584  REAL, INTENT(INOUT) :: yflux(bd%is:bd%ie, bd%js:bd%je+1)
2585 !------------------------
2586  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed)
2587  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1)
2588  LOGICAL, INTENT(IN) :: hydrostatic
2589  LOGICAL, INTENT(IN) :: inline_q
2590  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed), INTENT(OUT) :: &
2591 & crx_adv, xfx_adv
2592  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1), INTENT(OUT) :: &
2593 & cry_adv, yfx_adv
2594  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2595  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
2596 ! Local:
2597  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
2598  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
2599  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
2600 !---
2601  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed)
2602  REAL :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1)
2603 ! work array
2604  REAL :: dw(bd%is:bd%ie, bd%js:bd%je)
2605 !---
2606  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub, vb
2607 ! work array
2608  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
2609 ! needs this for corner_comm
2610  REAL :: ke(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
2611 ! Vorticity
2612  REAL :: vort(bd%isd:bd%ied, bd%jsd:bd%jed)
2613 ! 1-D X-direction Fluxes
2614  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
2615 ! 1-D Y-direction Fluxes
2616  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
2617  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
2618  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
2619  REAL :: gx(bd%is:bd%ie+1, bd%js:bd%je)
2620 ! work Y-dir flux array
2621  REAL :: gy(bd%is:bd%ie, bd%js:bd%je+1)
2622  LOGICAL :: fill_c
2623  REAL :: dt2, dt4, dt5, dt6
2624  REAL :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
2625  REAL :: u_lon
2626  INTEGER :: i, j, is2, ie1, js2, je1, n, nt, n2, iq
2627  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
2628  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
2629  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
2630  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
2631  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
2632  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
2633  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
2634 & , rdx, rdy
2635  INTEGER :: is, ie, js, je
2636  INTEGER :: isd, ied, jsd, jed
2637  INTEGER :: npx, npy
2638  LOGICAL :: nested
2639  REAL :: delp_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2640  REAL :: pt_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2641  REAL :: vort_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2642  REAL :: wk_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2643  REAL :: delpc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2644  REAL :: ptc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
2645  REAL :: ke_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
2646  REAL :: vc_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
2647  REAL :: uc_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
2648  REAL :: divg_d_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
2649  REAL :: ut_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
2650  REAL :: vt_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
2651  INTRINSIC max
2652  INTRINSIC min
2653  INTRINSIC abs
2654  INTEGER :: max1
2655  INTEGER :: max2
2656  INTEGER :: max3
2657  INTEGER :: max4
2658  REAL :: abs0
2659  INTEGER :: min1
2660  INTEGER :: min2
2661  INTEGER :: min3
2662  INTEGER :: min4
2663  REAL*8 :: pwx1
2664  INTEGER :: pwy1
2665  is = bd%is
2666  ie = bd%ie
2667  js = bd%js
2668  je = bd%je
2669  isd = bd%isd
2670  ied = bd%ied
2671  jsd = bd%jsd
2672  jed = bd%jed
2673  npx = flagstruct%npx
2674  npy = flagstruct%npy
2675  nested = gridstruct%nested
2676  area => gridstruct%area
2677  rarea => gridstruct%rarea
2678  sin_sg => gridstruct%sin_sg
2679  cosa_u => gridstruct%cosa_u
2680  cosa_v => gridstruct%cosa_v
2681  cosa_s => gridstruct%cosa_s
2682  sina_u => gridstruct%sina_u
2683  sina_v => gridstruct%sina_v
2684  rsin_u => gridstruct%rsin_u
2685  rsin_v => gridstruct%rsin_v
2686  rsina => gridstruct%rsina
2687  f0 => gridstruct%f0
2688  rsin2 => gridstruct%rsin2
2689  divg_u => gridstruct%divg_u
2690  divg_v => gridstruct%divg_v
2691  cosa => gridstruct%cosa
2692  dx => gridstruct%dx
2693  dy => gridstruct%dy
2694  dxc => gridstruct%dxc
2695  dyc => gridstruct%dyc
2696  rdxa => gridstruct%rdxa
2697  rdya => gridstruct%rdya
2698  rdx => gridstruct%rdx
2699  rdy => gridstruct%rdy
2700  sw_corner = gridstruct%sw_corner
2701  se_corner = gridstruct%se_corner
2702  nw_corner = gridstruct%nw_corner
2703  ne_corner = gridstruct%ne_corner
2704 ! end grid_type choices
2705  IF (flagstruct%grid_type .LT. 3) THEN
2706 !!! TO DO: separate versions for nesting and for cubed-sphere
2707  IF (nested) THEN
2708  DO j=jsd,jed
2709  DO i=is-1,ie+2
2710  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j)+&
2711 & vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
2712  END DO
2713  END DO
2714  DO j=js-1,je+2
2715  DO i=isd,ied
2716  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1, j&
2717 & -1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
2718  END DO
2719  END DO
2720  ELSE
2721  DO j=jsd,jed
2722  IF (j .NE. 0 .AND. j .NE. 1 .AND. j .NE. npy - 1 .AND. j .NE. &
2723 & npy) THEN
2724  DO i=is-1,ie+2
2725  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j&
2726 & )+vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
2727  END DO
2728  END IF
2729  END DO
2730  DO j=js-1,je+2
2731  IF (j .NE. 1 .AND. j .NE. npy) THEN
2732  DO i=isd,ied
2733  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1&
2734 & , j-1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
2735  END DO
2736  END IF
2737  END DO
2738  END IF
2739 !.not. nested
2740  IF (.NOT.nested) THEN
2741 ! West face
2742 ! West edge:
2743  IF (is .EQ. 1) THEN
2744  DO j=jsd,jed
2745  IF (uc(1, j)*dt .GT. 0.) THEN
2746  ut(1, j) = uc(1, j)/sin_sg(0, j, 3)
2747  ELSE
2748  ut(1, j) = uc(1, j)/sin_sg(1, j, 1)
2749  END IF
2750  END DO
2751  IF (3 .LT. js) THEN
2752  max1 = js
2753  ELSE
2754  max1 = 3
2755  END IF
2756  IF (npy - 2 .GT. je + 1) THEN
2757  min1 = je + 1
2758  ELSE
2759  min1 = npy - 2
2760  END IF
2761  DO j=max1,min1
2762  vt(0, j) = vc(0, j) - 0.25*cosa_v(0, j)*(ut(0, j-1)+ut(1, j-&
2763 & 1)+ut(0, j)+ut(1, j))
2764  vt(1, j) = vc(1, j) - 0.25*cosa_v(1, j)*(ut(1, j-1)+ut(2, j-&
2765 & 1)+ut(1, j)+ut(2, j))
2766  END DO
2767  END IF
2768 ! East edge:
2769  IF (ie + 1 .EQ. npx) THEN
2770  DO j=jsd,jed
2771  IF (uc(npx, j)*dt .GT. 0.) THEN
2772  ut(npx, j) = uc(npx, j)/sin_sg(npx-1, j, 3)
2773  ELSE
2774  ut(npx, j) = uc(npx, j)/sin_sg(npx, j, 1)
2775  END IF
2776  END DO
2777  IF (3 .LT. js) THEN
2778  max2 = js
2779  ELSE
2780  max2 = 3
2781  END IF
2782  IF (npy - 2 .GT. je + 1) THEN
2783  min2 = je + 1
2784  ELSE
2785  min2 = npy - 2
2786  END IF
2787  DO j=max2,min2
2788  vt(npx-1, j) = vc(npx-1, j) - 0.25*cosa_v(npx-1, j)*(ut(npx-&
2789 & 1, j-1)+ut(npx, j-1)+ut(npx-1, j)+ut(npx, j))
2790  vt(npx, j) = vc(npx, j) - 0.25*cosa_v(npx, j)*(ut(npx, j-1)+&
2791 & ut(npx+1, j-1)+ut(npx, j)+ut(npx+1, j))
2792  END DO
2793  END IF
2794 ! South (Bottom) edge:
2795  IF (js .EQ. 1) THEN
2796  DO i=isd,ied
2797  IF (vc(i, 1)*dt .GT. 0.) THEN
2798  vt(i, 1) = vc(i, 1)/sin_sg(i, 0, 4)
2799  ELSE
2800  vt(i, 1) = vc(i, 1)/sin_sg(i, 1, 2)
2801  END IF
2802  END DO
2803  IF (3 .LT. is) THEN
2804  max3 = is
2805  ELSE
2806  max3 = 3
2807  END IF
2808  IF (npx - 2 .GT. ie + 1) THEN
2809  min3 = ie + 1
2810  ELSE
2811  min3 = npx - 2
2812  END IF
2813  DO i=max3,min3
2814  ut(i, 0) = uc(i, 0) - 0.25*cosa_u(i, 0)*(vt(i-1, 0)+vt(i, 0)&
2815 & +vt(i-1, 1)+vt(i, 1))
2816  ut(i, 1) = uc(i, 1) - 0.25*cosa_u(i, 1)*(vt(i-1, 1)+vt(i, 1)&
2817 & +vt(i-1, 2)+vt(i, 2))
2818  END DO
2819  END IF
2820 ! North edge:
2821  IF (je + 1 .EQ. npy) THEN
2822  DO i=isd,ied
2823  IF (vc(i, npy)*dt .GT. 0.) THEN
2824  vt(i, npy) = vc(i, npy)/sin_sg(i, npy-1, 4)
2825  ELSE
2826  vt(i, npy) = vc(i, npy)/sin_sg(i, npy, 2)
2827  END IF
2828  END DO
2829  IF (3 .LT. is) THEN
2830  max4 = is
2831  ELSE
2832  max4 = 3
2833  END IF
2834  IF (npx - 2 .GT. ie + 1) THEN
2835  min4 = ie + 1
2836  ELSE
2837  min4 = npx - 2
2838  END IF
2839  DO i=max4,min4
2840  ut(i, npy-1) = uc(i, npy-1) - 0.25*cosa_u(i, npy-1)*(vt(i-1&
2841 & , npy-1)+vt(i, npy-1)+vt(i-1, npy)+vt(i, npy))
2842  ut(i, npy) = uc(i, npy) - 0.25*cosa_u(i, npy)*(vt(i-1, npy)+&
2843 & vt(i, npy)+vt(i-1, npy+1)+vt(i, npy+1))
2844  END DO
2845  END IF
2846 ! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values
2847 ! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously).
2848 ! It then computes the halo uc, vc values so as to be consistent with the computations on
2849 ! the facing panel.
2850 !The system solved is:
2851 ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1)
2852 ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2)
2853 ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1)
2854  IF (sw_corner) THEN
2855  damp = 1./(1.-0.0625*cosa_u(2, 0)*cosa_v(1, 0))
2856  ut(2, 0) = (uc(2, 0)-0.25*cosa_u(2, 0)*(vt(1, 1)+vt(2, 1)+vt(2&
2857 & , 0)+vc(1, 0)-0.25*cosa_v(1, 0)*(ut(1, 0)+ut(1, -1)+ut(2, -1&
2858 & ))))*damp
2859  damp = 1./(1.-0.0625*cosa_u(0, 1)*cosa_v(0, 2))
2860  vt(0, 2) = (vc(0, 2)-0.25*cosa_v(0, 2)*(ut(1, 1)+ut(1, 2)+ut(0&
2861 & , 2)+uc(0, 1)-0.25*cosa_u(0, 1)*(vt(0, 1)+vt(-1, 1)+vt(-1, 2&
2862 & ))))*damp
2863  damp = 1./(1.-0.0625*cosa_u(2, 1)*cosa_v(1, 2))
2864  ut(2, 1) = (uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2&
2865 & , 2)+vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2, 2))&
2866 & ))*damp
2867  vt(1, 2) = (vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2&
2868 & , 2)+uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2, 2))&
2869 & ))*damp
2870  END IF
2871  IF (se_corner) THEN
2872  damp = 1./(1.-0.0625*cosa_u(npx-1, 0)*cosa_v(npx-1, 0))
2873  ut(npx-1, 0) = (uc(npx-1, 0)-0.25*cosa_u(npx-1, 0)*(vt(npx-1, &
2874 & 1)+vt(npx-2, 1)+vt(npx-2, 0)+vc(npx-1, 0)-0.25*cosa_v(npx-1&
2875 & , 0)*(ut(npx, 0)+ut(npx, -1)+ut(npx-1, -1))))*damp
2876  damp = 1./(1.-0.0625*cosa_u(npx+1, 1)*cosa_v(npx, 2))
2877  vt(npx, 2) = (vc(npx, 2)-0.25*cosa_v(npx, 2)*(ut(npx, 1)+ut(&
2878 & npx, 2)+ut(npx+1, 2)+uc(npx+1, 1)-0.25*cosa_u(npx+1, 1)*(vt(&
2879 & npx, 1)+vt(npx+1, 1)+vt(npx+1, 2))))*damp
2880  damp = 1./(1.-0.0625*cosa_u(npx-1, 1)*cosa_v(npx-1, 2))
2881  ut(npx-1, 1) = (uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*(vt(npx-1, &
2882 & 1)+vt(npx-2, 1)+vt(npx-2, 2)+vc(npx-1, 2)-0.25*cosa_v(npx-1&
2883 & , 2)*(ut(npx, 1)+ut(npx, 2)+ut(npx-1, 2))))*damp
2884  vt(npx-1, 2) = (vc(npx-1, 2)-0.25*cosa_v(npx-1, 2)*(ut(npx, 1)&
2885 & +ut(npx, 2)+ut(npx-1, 2)+uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*&
2886 & (vt(npx-1, 1)+vt(npx-2, 1)+vt(npx-2, 2))))*damp
2887  END IF
2888  IF (ne_corner) THEN
2889  damp = 1./(1.-0.0625*cosa_u(npx-1, npy)*cosa_v(npx-1, npy+1))
2890  ut(npx-1, npy) = (uc(npx-1, npy)-0.25*cosa_u(npx-1, npy)*(vt(&
2891 & npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy+1)+vc(npx-1, npy+1)&
2892 & -0.25*cosa_v(npx-1, npy+1)*(ut(npx, npy)+ut(npx, npy+1)+ut(&
2893 & npx-1, npy+1))))*damp
2894  damp = 1./(1.-0.0625*cosa_u(npx+1, npy-1)*cosa_v(npx, npy-1))
2895  vt(npx, npy-1) = (vc(npx, npy-1)-0.25*cosa_v(npx, npy-1)*(ut(&
2896 & npx, npy-1)+ut(npx, npy-2)+ut(npx+1, npy-2)+uc(npx+1, npy-1)&
2897 & -0.25*cosa_u(npx+1, npy-1)*(vt(npx, npy)+vt(npx+1, npy)+vt(&
2898 & npx+1, npy-1))))*damp
2899  damp = 1./(1.-0.0625*cosa_u(npx-1, npy-1)*cosa_v(npx-1, npy-1)&
2900 & )
2901  ut(npx-1, npy-1) = (uc(npx-1, npy-1)-0.25*cosa_u(npx-1, npy-1)&
2902 & *(vt(npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy-1)+vc(npx-1, &
2903 & npy-1)-0.25*cosa_v(npx-1, npy-1)*(ut(npx, npy-1)+ut(npx, npy&
2904 & -2)+ut(npx-1, npy-2))))*damp
2905  vt(npx-1, npy-1) = (vc(npx-1, npy-1)-0.25*cosa_v(npx-1, npy-1)&
2906 & *(ut(npx, npy-1)+ut(npx, npy-2)+ut(npx-1, npy-2)+uc(npx-1, &
2907 & npy-1)-0.25*cosa_u(npx-1, npy-1)*(vt(npx-1, npy)+vt(npx-2, &
2908 & npy)+vt(npx-2, npy-1))))*damp
2909  END IF
2910  IF (nw_corner) THEN
2911  damp = 1./(1.-0.0625*cosa_u(2, npy)*cosa_v(1, npy+1))
2912  ut(2, npy) = (uc(2, npy)-0.25*cosa_u(2, npy)*(vt(1, npy)+vt(2&
2913 & , npy)+vt(2, npy+1)+vc(1, npy+1)-0.25*cosa_v(1, npy+1)*(ut(1&
2914 & , npy)+ut(1, npy+1)+ut(2, npy+1))))*damp
2915  damp = 1./(1.-0.0625*cosa_u(0, npy-1)*cosa_v(0, npy-1))
2916  vt(0, npy-1) = (vc(0, npy-1)-0.25*cosa_v(0, npy-1)*(ut(1, npy-&
2917 & 1)+ut(1, npy-2)+ut(0, npy-2)+uc(0, npy-1)-0.25*cosa_u(0, npy&
2918 & -1)*(vt(0, npy)+vt(-1, npy)+vt(-1, npy-1))))*damp
2919  damp = 1./(1.-0.0625*cosa_u(2, npy-1)*cosa_v(1, npy-1))
2920  ut(2, npy-1) = (uc(2, npy-1)-0.25*cosa_u(2, npy-1)*(vt(1, npy)&
2921 & +vt(2, npy)+vt(2, npy-1)+vc(1, npy-1)-0.25*cosa_v(1, npy-1)*&
2922 & (ut(1, npy-1)+ut(1, npy-2)+ut(2, npy-2))))*damp
2923  vt(1, npy-1) = (vc(1, npy-1)-0.25*cosa_v(1, npy-1)*(ut(1, npy-&
2924 & 1)+ut(1, npy-2)+ut(2, npy-2)+uc(2, npy-1)-0.25*cosa_u(2, npy&
2925 & -1)*(vt(1, npy)+vt(2, npy)+vt(2, npy-1))))*damp
2926  END IF
2927  END IF
2928  ELSE
2929 ! flagstruct%grid_type >= 3
2930  DO j=jsd,jed
2931  DO i=is,ie+1
2932  ut(i, j) = uc(i, j)
2933  END DO
2934  END DO
2935  DO j=js,je+1
2936  DO i=isd,ied
2937  vt(i, j) = vc(i, j)
2938  END DO
2939  END DO
2940  END IF
2941  DO j=jsd,jed
2942  DO i=is,ie+1
2943  xfx_adv(i, j) = dt*ut(i, j)
2944  END DO
2945  END DO
2946  DO j=js,je+1
2947  DO i=isd,ied
2948  yfx_adv(i, j) = dt*vt(i, j)
2949  END DO
2950  END DO
2951 ! Explanation of the following code:
2952 ! xfx_adv = dt*ut*dy
2953 ! crx_adv = dt*ut/dx
2954  DO j=jsd,jed
2955 !DEC$ VECTOR ALWAYS
2956  DO i=is,ie+1
2957  IF (xfx_adv(i, j) .GT. 0.) THEN
2958  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i-1, j)
2959  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i-1, j, 3)
2960  ELSE
2961  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i, j)
2962  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i, j, 1)
2963  END IF
2964  END DO
2965  END DO
2966  DO j=js,je+1
2967 !DEC$ VECTOR ALWAYS
2968  DO i=isd,ied
2969  IF (yfx_adv(i, j) .GT. 0.) THEN
2970  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j-1)
2971  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j-1, 4)
2972  ELSE
2973  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j)
2974  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j, 2)
2975  END IF
2976  END DO
2977  END DO
2978  DO j=jsd,jed
2979  DO i=is,ie
2980  ra_x(i, j) = area(i, j) + (xfx_adv(i, j)-xfx_adv(i+1, j))
2981  END DO
2982  END DO
2983  DO j=js,je
2984  DO i=isd,ied
2985  ra_y(i, j) = area(i, j) + (yfx_adv(i, j)-yfx_adv(i, j+1))
2986  END DO
2987  END DO
2988  IF (hord_dp .EQ. hord_dp_pert .AND. (.NOT.split_damp)) THEN
2989  CALL fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy&
2990 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, nord=&
2991 & nord_v, damp_c=damp_v)
2992  ELSE
2993  call fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy, &
2994  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, nord=nord_v, damp_c=damp_v)
2995  END IF
2996 ! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>>
2997  DO j=jsd,jed
2998  DO i=is,ie+1
2999  cx(i, j) = cx(i, j) + crx_adv(i, j)
3000  END DO
3001  END DO
3002  DO j=js,je
3003  DO i=is,ie+1
3004  xflux(i, j) = xflux(i, j) + fx(i, j)
3005  END DO
3006  END DO
3007  DO j=js,je+1
3008  DO i=isd,ied
3009  cy(i, j) = cy(i, j) + cry_adv(i, j)
3010  END DO
3011  DO i=is,ie
3012  yflux(i, j) = yflux(i, j) + fy(i, j)
3013  END DO
3014  END DO
3015  DO j=js,je
3016  DO i=is,ie
3017  heat_source(i, j) = 0.
3018  END DO
3019  END DO
3020  IF (.NOT.hydrostatic) THEN
3021  IF (damp_w .GT. 1.e-5) THEN
3022  IF (dt .GE. 0.) THEN
3023  abs0 = dt
3024  ELSE
3025  abs0 = -dt
3026  END IF
3027  dd8 = kgb*abs0
3028  pwx1 = damp_w*gridstruct%da_min_c
3029  pwy1 = nord_w + 1
3030  damp4 = pwx1**pwy1
3031  CALL del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, &
3032 & gridstruct, bd)
3033  DO j=js,je
3034  DO i=is,ie
3035  dw(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
3036 & rarea(i, j)
3037 ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw
3038 ! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j))
3039  heat_source(i, j) = dd8 - dw(i, j)*(w(i, j)+0.5*dw(i, j))
3040  END DO
3041  END DO
3042  END IF
3043  IF (hord_vt .EQ. hord_vt_pert) THEN
3044  CALL fv_tp_2d(w, crx_adv, cry_adv, npx, npy, hord_vt, gx, gy&
3045 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=&
3046 & fx, mfy=fy)
3047  ELSE
3048  call fv_tp_2d(w, crx_adv,cry_adv, npx, npy, hord_vt, gx, gy, xfx_adv, yfx_adv, &
3049  gridstruct, bd, ra_x, ra_y, mfx=fx, mfy=fy)
3050  END IF
3051  DO j=js,je
3052  DO i=is,ie
3053  w(i, j) = delp(i, j)*w(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j)-&
3054 & gy(i, j+1)))*rarea(i, j)
3055  END DO
3056  END DO
3057  END IF
3058 ! if ( inline_q .and. zvir>0.01 ) then
3059 ! do j=jsd,jed
3060 ! do i=isd,ied
3061 ! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum))
3062 ! enddo
3063 ! enddo
3064 ! endif
3065  IF (hord_tm .EQ. hord_tm_pert .AND. (.NOT.split_damp)) THEN
3066  CALL fv_tp_2d(pt, crx_adv, cry_adv, npx, npy, hord_tm, gx, gy, &
3067 & xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, fx, fy, &
3068 & delp, nord_t, damp_t)
3069  ELSE
3070  call fv_tp_2d(pt, crx_adv,cry_adv, npx, npy, hord_tm, gx, gy, &
3071  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, &
3072  mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
3073  END IF
3074  IF (inline_q) THEN
3075  DO j=js,je
3076  DO i=is,ie
3077  wk(i, j) = delp(i, j)
3078  delp(i, j) = wk(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
3079 & +1)))*rarea(i, j)
3080  pt(i, j) = (pt(i, j)*wk(i, j)+(gx(i, j)-gx(i+1, j)+(gy(i, j)-&
3081 & gy(i, j+1)))*rarea(i, j))/delp(i, j)
3082  END DO
3083  END DO
3084  DO iq=1,nq
3085  IF (hord_tr .EQ. hord_tr_pert) THEN
3086  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), crx_adv, cry_adv&
3087 & , npx, npy, hord_tr, gx, gy, xfx_adv, yfx_adv, &
3088 & gridstruct, bd, ra_x, ra_y, fx, fy, delp, nord_t, &
3089 & damp_t)
3090  ELSE
3091  call fv_tp_2d(q(isd:ied,jsd:jed,k,iq), crx_adv,cry_adv, npx, npy, hord_tr, gx, gy, &
3092  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y, &
3093  mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
3094  END IF
3095  DO j=js,je
3096  DO i=is,ie
3097  q(i, j, k, iq) = (q(i, j, k, iq)*wk(i, j)+(gx(i, j)-gx(i+1, &
3098 & j)+(gy(i, j)-gy(i, j+1)))*rarea(i, j))/delp(i, j)
3099  END DO
3100  END DO
3101  END DO
3102  ELSE
3103 ! if ( zvir>0.01 ) then
3104 ! do j=js,je
3105 ! do i=is,ie
3106 ! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum))
3107 ! enddo
3108 ! enddo
3109 ! endif
3110  DO j=js,je
3111  DO i=is,ie
3112  pt(i, j) = pt(i, j)*delp(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j&
3113 & )-gy(i, j+1)))*rarea(i, j)
3114  delp(i, j) = delp(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i&
3115 & , j+1)))*rarea(i, j)
3116  pt(i, j) = pt(i, j)/delp(i, j)
3117  END DO
3118  END DO
3119  END IF
3120  IF (fpp%fpp_overload_r4) THEN
3121  DO j=js,je
3122  DO i=is,ie
3123  dpx(i, j) = dpx(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
3124 & +1)))*rarea(i, j)
3125  END DO
3126  END DO
3127  END IF
3128 !----------------------
3129 ! Kinetic Energy Fluxes
3130 !----------------------
3131 ! Compute B grid contra-variant components for KE:
3132  dt5 = 0.5*dt
3133  dt4 = 0.25*dt
3134  IF (nested) THEN
3135  is2 = is
3136  ie1 = ie + 1
3137  js2 = js
3138  je1 = je + 1
3139  ELSE
3140  IF (2 .LT. is) THEN
3141  is2 = is
3142  ELSE
3143  is2 = 2
3144  END IF
3145  IF (npx - 1 .GT. ie + 1) THEN
3146  ie1 = ie + 1
3147  ELSE
3148  ie1 = npx - 1
3149  END IF
3150  IF (2 .LT. js) THEN
3151  js2 = js
3152  ELSE
3153  js2 = 2
3154  END IF
3155  IF (npy - 1 .GT. je + 1) THEN
3156  je1 = je + 1
3157  ELSE
3158  je1 = npy - 1
3159  END IF
3160  END IF
3161 !!! TO DO: separate versions for nested and for cubed-sphere
3162  IF (flagstruct%grid_type .LT. 3) THEN
3163  IF (nested) THEN
3164  DO j=js2,je1
3165  DO i=is2,ie1
3166  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
3167 & cosa(i, j))*rsina(i, j)
3168  END DO
3169  END DO
3170  ELSE
3171  IF (js .EQ. 1) THEN
3172  DO i=is,ie+1
3173 ! corner values are incorrect
3174  vb(i, 1) = dt5*(vt(i-1, 1)+vt(i, 1))
3175  END DO
3176  END IF
3177  DO j=js2,je1
3178  DO i=is2,ie1
3179  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
3180 & cosa(i, j))*rsina(i, j)
3181  END DO
3182  IF (is .EQ. 1) vb(1, j) = dt4*(-vt(-1, j)+3.*(vt(0, j)+vt(1, j&
3183 & ))-vt(2, j))
3184 ! 2-pt extrapolation from both sides:
3185  IF (ie + 1 .EQ. npx) vb(npx, j) = dt4*(-vt(npx-2, j)+3.*(vt(&
3186 & npx-1, j)+vt(npx, j))-vt(npx+1, j))
3187 ! 2-pt extrapolation from both sides:
3188  END DO
3189  IF (je + 1 .EQ. npy) THEN
3190  DO i=is,ie+1
3191 ! corner values are incorrect
3192  vb(i, npy) = dt5*(vt(i-1, npy)+vt(i, npy))
3193  END DO
3194  END IF
3195  END IF
3196  ELSE
3197  DO j=js,je+1
3198  DO i=is,ie+1
3199  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j))
3200  END DO
3201  END DO
3202  END IF
3203  IF (hord_mt .EQ. hord_mt_pert) THEN
3204  CALL ytp_v(is, ie, js, je, isd, ied, jsd, jed, vb, u, v, ub, &
3205 & hord_mt, gridstruct%dy, gridstruct%rdy, npx, npy, &
3206 & flagstruct%grid_type, nested)
3207  ELSE
3208  call ytp_v(is,ie,js,je,isd,ied,jsd,jed, vb, u, v, ub, hord_mt, gridstruct%dy, gridstruct%rdy, &
3209  npx, npy, flagstruct%grid_type, nested)
3210  END IF
3211  DO j=js,je+1
3212  DO i=is,ie+1
3213  ke(i, j) = vb(i, j)*ub(i, j)
3214  END DO
3215  END DO
3216  IF (flagstruct%grid_type .LT. 3) THEN
3217  IF (nested) THEN
3218  DO j=js,je+1
3219  DO i=is2,ie1
3220  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
3221 & cosa(i, j))*rsina(i, j)
3222  END DO
3223  END DO
3224  ELSE
3225  IF (is .EQ. 1) THEN
3226  DO j=js,je+1
3227 ! corner values are incorrect
3228  ub(1, j) = dt5*(ut(1, j-1)+ut(1, j))
3229  END DO
3230  END IF
3231  DO j=js,je+1
3232  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
3233  DO i=is2,ie1
3234 ! 2-pt extrapolation from both sides:
3235  ub(i, j) = dt4*(-ut(i, j-2)+3.*(ut(i, j-1)+ut(i, j))-ut(i&
3236 & , j+1))
3237  END DO
3238  ELSE
3239  DO i=is2,ie1
3240  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
3241 & cosa(i, j))*rsina(i, j)
3242  END DO
3243  END IF
3244  END DO
3245  IF (ie + 1 .EQ. npx) THEN
3246  DO j=js,je+1
3247 ! corner values are incorrect
3248  ub(npx, j) = dt5*(ut(npx, j-1)+ut(npx, j))
3249  END DO
3250  END IF
3251  END IF
3252  ELSE
3253  DO j=js,je+1
3254  DO i=is,ie+1
3255  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j))
3256  END DO
3257  END DO
3258  END IF
3259  IF (hord_mt .EQ. hord_mt_pert) THEN
3260  CALL xtp_u(is, ie, js, je, isd, ied, jsd, jed, ub, u, v, vb, &
3261 & hord_mt, gridstruct%dx, gridstruct%rdx, npx, npy, &
3262 & flagstruct%grid_type, nested)
3263  ELSE
3264  call xtp_u(is,ie,js,je, isd,ied,jsd,jed, ub, u, v, vb, hord_mt, gridstruct%dx, gridstruct%rdx, &
3265  npx, npy, flagstruct%grid_type, nested)
3266  END IF
3267  DO j=js,je+1
3268  DO i=is,ie+1
3269  ke(i, j) = 0.5*(ke(i, j)+ub(i, j)*vb(i, j))
3270  END DO
3271  END DO
3272 !-----------------------------------------
3273 ! Fix KE at the 4 corners of the face:
3274 !-----------------------------------------
3275  IF (.NOT.nested) THEN
3276  dt6 = dt/6.
3277  IF (sw_corner) ke(1, 1) = dt6*((ut(1, 1)+ut(1, 0))*u(1, 1)+(vt(1, &
3278 & 1)+vt(0, 1))*v(1, 1)+(ut(1, 1)+vt(1, 1))*u(0, 1))
3279  IF (se_corner) ke(npx, 1) = dt6*((ut(npx, 1)+ut(npx, 0))*u(npx-1, &
3280 & 1)+(vt(npx, 1)+vt(npx-1, 1))*v(npx, 1)+(ut(npx, 1)-vt(npx-1, 1&
3281 & ))*u(npx, 1))
3282 !i = npx
3283  IF (ne_corner) ke(npx, npy) = dt6*((ut(npx, npy)+ut(npx, npy-1))*u&
3284 & (npx-1, npy)+(vt(npx, npy)+vt(npx-1, npy))*v(npx, npy-1)+(ut(&
3285 & npx, npy-1)+vt(npx-1, npy))*u(npx, npy))
3286 !i = npx; j = npy
3287  IF (nw_corner) ke(1, npy) = dt6*((ut(1, npy)+ut(1, npy-1))*u(1, &
3288 & npy)+(vt(1, npy)+vt(0, npy))*v(1, npy-1)+(ut(1, npy-1)-vt(1, &
3289 & npy))*u(0, npy))
3290 !j = npy
3291  END IF
3292 ! Compute vorticity:
3293  DO j=jsd,jed+1
3294  DO i=isd,ied
3295  vt(i, j) = u(i, j)*dx(i, j)
3296  END DO
3297  END DO
3298  DO j=jsd,jed
3299  DO i=isd,ied+1
3300  ut(i, j) = v(i, j)*dy(i, j)
3301  END DO
3302  END DO
3303 ! wk is "volume-mean" relative vorticity
3304  DO j=jsd,jed
3305  DO i=isd,ied
3306  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i+1, j)-ut(i, j)&
3307 & ))
3308  END DO
3309  END DO
3310  IF (.NOT.hydrostatic) THEN
3311  IF (.NOT.flagstruct%do_f3d) THEN
3312  DO j=js,je
3313  DO i=is,ie
3314  w(i, j) = w(i, j)/delp(i, j)
3315  END DO
3316  END DO
3317  END IF
3318  IF (damp_w .GT. 1.e-5) THEN
3319  DO j=js,je
3320  DO i=is,ie
3321  w(i, j) = w(i, j) + dw(i, j)
3322  END DO
3323  END DO
3324  END IF
3325  END IF
3326 !-----------------------------
3327 ! Compute divergence damping
3328 !-----------------------------
3329 !! damp = dddmp * da_min_c
3330 !
3331 ! if ( nord==0 ) then
3332 !! area ~ dxb*dyb*sin(alpha)
3333 !
3334 ! if (nested) then
3335 !
3336 ! do j=js,je+1
3337 ! do i=is-1,ie+1
3338 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
3339 ! *dyc(i,j)*sina_v(i,j)
3340 ! enddo
3341 ! enddo
3342 !
3343 ! do j=js-1,je+1
3344 ! do i=is2,ie1
3345 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
3346 ! *dxc(i,j)*sina_u(i,j)
3347 ! enddo
3348 ! enddo
3349 !
3350 ! else
3351 ! do j=js,je+1
3352 !
3353 ! if ( (j==1 .or. j==npy) ) then
3354 ! do i=is-1,ie+1
3355 ! if (vc(i,j) > 0) then
3356 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4)
3357 ! else
3358 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2)
3359 ! end if
3360 ! enddo
3361 ! else
3362 ! do i=is-1,ie+1
3363 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
3364 ! *dyc(i,j)*sina_v(i,j)
3365 ! enddo
3366 ! endif
3367 ! enddo
3368 !
3369 ! do j=js-1,je+1
3370 ! do i=is2,ie1
3371 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
3372 ! *dxc(i,j)*sina_u(i,j)
3373 ! enddo
3374 ! if ( is == 1 ) then
3375 ! if (uc(1,j) > 0) then
3376 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3)
3377 ! else
3378 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1)
3379 ! end if
3380 ! end if
3381 ! if ( (ie+1)==npx ) then
3382 ! if (uc(npx,j) > 0) then
3383 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
3384 ! sin_sg(npx-1,j,3)
3385 ! else
3386 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
3387 ! sin_sg(npx,j,1)
3388 ! end if
3389 ! end if
3390 ! enddo
3391 ! endif
3392 !
3393 ! do j=js,je+1
3394 ! do i=is,ie+1
3395 ! delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j)
3396 ! enddo
3397 ! enddo
3398 !
3399 !! Remove the extra term at the corners:
3400 ! if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
3401 ! if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
3402 ! if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy)
3403 ! if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
3404 !
3405 ! do j=js,je+1
3406 ! do i=is,ie+1
3407 ! delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j)
3408 ! damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt)))
3409 ! vort(i,j) = damp*delpc(i,j)
3410 ! ke(i,j) = ke(i,j) + vort(i,j)
3411 ! enddo
3412 ! enddo
3413 ! else
3414 !!--------------------------
3415 !! Higher order divg damping
3416 !!--------------------------
3417 ! do j=js,je+1
3418 ! do i=is,ie+1
3419 !! Save divergence for external mode filter
3420 ! delpc(i,j) = divg_d(i,j)
3421 ! enddo
3422 ! enddo
3423 !
3424 ! n2 = nord + 1 ! N > 1
3425 ! do n=1,nord
3426 ! nt = nord-n
3427 !
3428 ! fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. &
3429 ! ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) &
3430 ! .and. .not. nested
3431 !
3432 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.)
3433 ! do j=js-nt,je+1+nt
3434 ! do i=is-1-nt,ie+1+nt
3435 ! vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j)
3436 ! enddo
3437 ! enddo
3438 !
3439 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.)
3440 ! do j=js-1-nt,je+1+nt
3441 ! do i=is-nt,ie+1+nt
3442 ! uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j)
3443 ! enddo
3444 ! enddo
3445 !
3446 ! if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.)
3447 ! do j=js-nt,je+1+nt
3448 ! do i=is-nt,ie+1+nt
3449 ! divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j)
3450 ! enddo
3451 ! enddo
3452 !
3453 !! Remove the extra term at the corners:
3454 ! if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
3455 ! if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
3456 ! if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy)
3457 ! if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
3458 !
3459 ! if ( .not. gridstruct%stretched_grid ) then
3460 ! do j=js-nt,je+1+nt
3461 ! do i=is-nt,ie+1+nt
3462 ! divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j)
3463 ! enddo
3464 ! enddo
3465 ! endif
3466 !
3467 ! enddo ! n-loop
3468 !
3469 ! if ( dddmp<1.E-5) then
3470 ! vort(:,:) = 0.
3471 ! else
3472 ! if ( flagstruct%grid_type < 3 ) then
3473 !! Interpolate relative vort to cell corners
3474 ! call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.)
3475 ! do j=js,je+1
3476 ! do i=is,ie+1
3477 !! The following is an approxi form of Smagorinsky diffusion
3478 ! vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2)
3479 ! enddo
3480 ! enddo
3481 ! else ! Correct form: works only for doubly preiodic domain
3482 ! call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng)
3483 ! endif
3484 ! endif
3485 !
3486 ! if (gridstruct%stretched_grid ) then
3487 !! Stretched grid with variable damping ~ area
3488 ! dd8 = gridstruct%da_min * d4_bg**n2
3489 ! else
3490 ! dd8 = ( gridstruct%da_min_c*d4_bg )**n2
3491 ! endif
3492 !
3493 ! do j=js,je+1
3494 ! do i=is,ie+1
3495 ! damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2
3496 ! vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j)
3497 ! ke(i,j) = ke(i,j) + vort(i,j)
3498 ! enddo
3499 ! enddo
3500 !
3501 ! endif
3502  IF (.NOT.split_damp) THEN
3503  CALL compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, &
3504 & vort, ptc, delpc, ke, u, v, uc, vc, &
3505 & ua, va, divg_d, wk, gridstruct, &
3506 & flagstruct, bd)
3507  ELSE
3508  call compute_divergence_damping( nord,d2_bg,d4_bg,dddmp,dt, &
3509  vort,ptc,delpc,ke,u,v,uc,vc,ua,va,divg_d,wk, &
3510  gridstruct, flagstruct, bd)
3511  END IF
3512  IF (d_con .GT. 1.e-5) THEN
3513  DO j=js,je+1
3514  DO i=is,ie
3515  ub(i, j) = vort(i, j) - vort(i+1, j)
3516  END DO
3517  END DO
3518  DO j=js,je
3519  DO i=is,ie+1
3520  vb(i, j) = vort(i, j) - vort(i, j+1)
3521  END DO
3522  END DO
3523  END IF
3524 ! Vorticity transport
3525  IF (hydrostatic) THEN
3526  DO j=jsd,jed
3527  DO i=isd,ied
3528  vort(i, j) = wk(i, j) + f0(i, j)
3529  END DO
3530  END DO
3531  ELSE IF (flagstruct%do_f3d) THEN
3532  DO j=jsd,jed
3533  DO i=isd,ied
3534  vort(i, j) = wk(i, j) + f0(i, j)*z_rat(i, j)
3535  END DO
3536  END DO
3537  ELSE
3538  DO j=jsd,jed
3539  DO i=isd,ied
3540  vort(i, j) = wk(i, j) + f0(i, j)
3541  END DO
3542  END DO
3543  END IF
3544  IF (hord_vt .EQ. hord_vt_pert) THEN
3545  CALL fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy&
3546 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y)
3547  ELSE
3548  call fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy, &
3549  xfx_adv,yfx_adv, gridstruct, bd, ra_x, ra_y)
3550  END IF
3551  DO j=js,je+1
3552  DO i=is,ie
3553  u(i, j) = vt(i, j) + (ke(i, j)-ke(i+1, j)) + fy(i, j)
3554  END DO
3555  END DO
3556  DO j=js,je
3557  DO i=is,ie+1
3558  v(i, j) = ut(i, j) + (ke(i, j)-ke(i, j+1)) - fx(i, j)
3559  END DO
3560  END DO
3561 !--------------------------------------------------------
3562 ! damping applied to relative vorticity (wk):
3563  IF (damp_v .GT. 1.e-5) THEN
3564  pwx1 = damp_v*gridstruct%da_min_c
3565  pwy1 = nord_v + 1
3566  damp4 = pwx1**pwy1
3567  CALL del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, &
3568 & gridstruct, bd)
3569  END IF
3570  IF (d_con .GT. 1.e-5) THEN
3571  DO j=js,je+1
3572  DO i=is,ie
3573  ub(i, j) = (ub(i, j)+vt(i, j))*rdx(i, j)
3574  fy(i, j) = u(i, j)*rdx(i, j)
3575  gy(i, j) = fy(i, j)*ub(i, j)
3576  END DO
3577  END DO
3578  DO j=js,je
3579  DO i=is,ie+1
3580  vb(i, j) = (vb(i, j)-ut(i, j))*rdy(i, j)
3581  fx(i, j) = v(i, j)*rdy(i, j)
3582  gx(i, j) = fx(i, j)*vb(i, j)
3583  END DO
3584  END DO
3585 !----------------------------------
3586 ! Heating due to damping:
3587 !----------------------------------
3588  damp = 0.25*d_con
3589  DO j=js,je
3590  DO i=is,ie
3591  u2 = fy(i, j) + fy(i, j+1)
3592  du2 = ub(i, j) + ub(i, j+1)
3593  v2 = fx(i, j) + fx(i+1, j)
3594  dv2 = vb(i, j) + vb(i+1, j)
3595 ! Total energy conserving:
3596 ! Convert lost KE due to divergence damping to "heat"
3597  heat_source(i, j) = delp(i, j)*(heat_source(i, j)-damp*rsin2(i&
3598 & , j)*(ub(i, j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j)**2+2.&
3599 & *(gy(i, j)+gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, j)*(u2*&
3600 & dv2+v2*du2+du2*dv2)))
3601  END DO
3602  END DO
3603  END IF
3604 ! Add diffusive fluxes to the momentum equation:
3605  IF (damp_v .GT. 1.e-5) THEN
3606  DO j=js,je+1
3607  DO i=is,ie
3608  u(i, j) = u(i, j) + vt(i, j)
3609  END DO
3610  END DO
3611  DO j=js,je
3612  DO i=is,ie+1
3613  v(i, j) = v(i, j) - ut(i, j)
3614  END DO
3615  END DO
3616  END IF
3617  END SUBROUTINE d_sw
3618 ! Differentiation of del6_vt_flux in forward (tangent) mode:
3619 ! variations of useful results: fy2 d2 fx2
3620 ! with respect to varying inputs: q fy2 d2 fx2
3621  SUBROUTINE del6_vt_flux_tlm(nord, npx, npy, damp, q, q_tl, d2, d2_tl, &
3622 & fx2, fx2_tl, fy2, fy2_tl, gridstruct, bd)
3623  IMPLICIT NONE
3624 ! Del-nord damping for the relative vorticity
3625 ! nord must be <= 2
3626 !------------------
3627 ! nord = 0: del-2
3628 ! nord = 1: del-4
3629 ! nord = 2: del-6
3630 !------------------
3631  INTEGER, INTENT(IN) :: nord, npx, npy
3632  REAL, INTENT(IN) :: damp
3633  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3634 ! rel. vorticity ghosted on input
3635  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
3636  REAL, INTENT(INOUT) :: q_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
3637  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3638 ! Work arrays:
3639  REAL, INTENT(OUT) :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
3640  REAL, INTENT(OUT) :: d2_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
3641  REAL, INTENT(OUT) :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd&
3642 & :bd%ied, bd%jsd:bd%jed+1)
3643  REAL, INTENT(OUT) :: fx2_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2_tl(&
3644 & bd%isd:bd%ied, bd%jsd:bd%jed+1)
3645  INTEGER :: i, j, nt, n, i1, i2, j1, j2
3646  LOGICAL :: nested
3647  INTEGER :: is, ie, js, je
3648  nested = gridstruct%nested
3649  is = bd%is
3650  ie = bd%ie
3651  js = bd%js
3652  je = bd%je
3653  i1 = is - 1 - nord
3654  i2 = ie + 1 + nord
3655  j1 = js - 1 - nord
3656  j2 = je + 1 + nord
3657  DO j=j1,j2
3658  DO i=i1,i2
3659  d2_tl(i, j) = damp*q_tl(i, j)
3660  d2(i, j) = damp*q(i, j)
3661  END DO
3662  END DO
3663  IF (nord .GT. 0) CALL copy_corners_tlm(d2, d2_tl, npx, npy, 1, &
3664 & nested, bd, gridstruct%sw_corner, &
3665 & gridstruct%se_corner, gridstruct%&
3666 & nw_corner, gridstruct%ne_corner)
3667  DO j=js-nord,je+nord
3668  DO i=is-nord,ie+nord+1
3669  fx2_tl(i, j) = gridstruct%del6_v(i, j)*(d2_tl(i-1, j)-d2_tl(i, j&
3670 & ))
3671  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
3672  END DO
3673  END DO
3674  IF (nord .GT. 0) CALL copy_corners_tlm(d2, d2_tl, npx, npy, 2, &
3675 & nested, bd, gridstruct%sw_corner, &
3676 & gridstruct%se_corner, gridstruct%&
3677 & nw_corner, gridstruct%ne_corner)
3678  DO j=js-nord,je+nord+1
3679  DO i=is-nord,ie+nord
3680  fy2_tl(i, j) = gridstruct%del6_u(i, j)*(d2_tl(i, j-1)-d2_tl(i, j&
3681 & ))
3682  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
3683  END DO
3684  END DO
3685  IF (nord .GT. 0) THEN
3686  DO n=1,nord
3687  nt = nord - n
3688  DO j=js-nt-1,je+nt+1
3689  DO i=is-nt-1,ie+nt+1
3690  d2_tl(i, j) = gridstruct%rarea(i, j)*(fx2_tl(i, j)-fx2_tl(i+&
3691 & 1, j)+fy2_tl(i, j)-fy2_tl(i, j+1))
3692  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
3693 & gridstruct%rarea(i, j)
3694  END DO
3695  END DO
3696  CALL copy_corners_tlm(d2, d2_tl, npx, npy, 1, nested, bd, &
3697 & gridstruct%sw_corner, gridstruct%se_corner, &
3698 & gridstruct%nw_corner, gridstruct%ne_corner)
3699  DO j=js-nt,je+nt
3700  DO i=is-nt,ie+nt+1
3701  fx2_tl(i, j) = gridstruct%del6_v(i, j)*(d2_tl(i, j)-d2_tl(i-&
3702 & 1, j))
3703  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
3704  END DO
3705  END DO
3706  CALL copy_corners_tlm(d2, d2_tl, npx, npy, 2, nested, bd, &
3707 & gridstruct%sw_corner, gridstruct%se_corner, &
3708 & gridstruct%nw_corner, gridstruct%ne_corner)
3709  DO j=js-nt,je+nt+1
3710  DO i=is-nt,ie+nt
3711  fy2_tl(i, j) = gridstruct%del6_u(i, j)*(d2_tl(i, j)-d2_tl(i&
3712 & , j-1))
3713  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
3714  END DO
3715  END DO
3716  END DO
3717  END IF
3718  END SUBROUTINE del6_vt_flux_tlm
3719  SUBROUTINE del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, &
3720 & gridstruct, bd)
3721  IMPLICIT NONE
3722 ! Del-nord damping for the relative vorticity
3723 ! nord must be <= 2
3724 !------------------
3725 ! nord = 0: del-2
3726 ! nord = 1: del-4
3727 ! nord = 2: del-6
3728 !------------------
3729  INTEGER, INTENT(IN) :: nord, npx, npy
3730  REAL, INTENT(IN) :: damp
3731  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3732 ! rel. vorticity ghosted on input
3733  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
3734  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3735 ! Work arrays:
3736  REAL, INTENT(OUT) :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
3737  REAL, INTENT(OUT) :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd&
3738 & :bd%ied, bd%jsd:bd%jed+1)
3739  INTEGER :: i, j, nt, n, i1, i2, j1, j2
3740  LOGICAL :: nested
3741  INTEGER :: is, ie, js, je
3742  nested = gridstruct%nested
3743  is = bd%is
3744  ie = bd%ie
3745  js = bd%js
3746  je = bd%je
3747  i1 = is - 1 - nord
3748  i2 = ie + 1 + nord
3749  j1 = js - 1 - nord
3750  j2 = je + 1 + nord
3751  DO j=j1,j2
3752  DO i=i1,i2
3753  d2(i, j) = damp*q(i, j)
3754  END DO
3755  END DO
3756  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 1, nested, bd, &
3757 & gridstruct%sw_corner, gridstruct%&
3758 & se_corner, gridstruct%nw_corner, &
3759 & gridstruct%ne_corner)
3760  DO j=js-nord,je+nord
3761  DO i=is-nord,ie+nord+1
3762  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
3763  END DO
3764  END DO
3765  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 2, nested, bd, &
3766 & gridstruct%sw_corner, gridstruct%&
3767 & se_corner, gridstruct%nw_corner, &
3768 & gridstruct%ne_corner)
3769  DO j=js-nord,je+nord+1
3770  DO i=is-nord,ie+nord
3771  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
3772  END DO
3773  END DO
3774  IF (nord .GT. 0) THEN
3775  DO n=1,nord
3776  nt = nord - n
3777  DO j=js-nt-1,je+nt+1
3778  DO i=is-nt-1,ie+nt+1
3779  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
3780 & gridstruct%rarea(i, j)
3781  END DO
3782  END DO
3783  CALL copy_corners(d2, npx, npy, 1, nested, bd, gridstruct%&
3784 & sw_corner, gridstruct%se_corner, gridstruct%&
3785 & nw_corner, gridstruct%ne_corner)
3786  DO j=js-nt,je+nt
3787  DO i=is-nt,ie+nt+1
3788  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
3789  END DO
3790  END DO
3791  CALL copy_corners(d2, npx, npy, 2, nested, bd, gridstruct%&
3792 & sw_corner, gridstruct%se_corner, gridstruct%&
3793 & nw_corner, gridstruct%ne_corner)
3794  DO j=js-nt,je+nt+1
3795  DO i=is-nt,ie+nt
3796  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
3797  END DO
3798  END DO
3799  END DO
3800  END IF
3801  END SUBROUTINE del6_vt_flux
3802 ! Differentiation of divergence_corner in forward (tangent) mode:
3803 ! variations of useful results: divg_d
3804 ! with respect to varying inputs: u v ua va divg_d
3805  SUBROUTINE divergence_corner_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, &
3806 & va_tl, divg_d, divg_d_tl, gridstruct, flagstruct, bd)
3807  IMPLICIT NONE
3808  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3809  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
3810  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u_tl
3811  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
3812  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v_tl
3813  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
3814  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua_tl, &
3815 & va_tl
3816  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
3817 & divg_d
3818  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
3819 & divg_d_tl
3820  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3821  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
3822 ! local
3823  REAL :: uf(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
3824  REAL :: uf_tl(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
3825  REAL :: vf(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
3826  REAL :: vf_tl(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
3827  INTEGER :: i, j
3828  INTEGER :: is2, ie1
3829  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
3830  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
3831  INTEGER :: is, ie, js, je
3832  INTEGER :: npx, npy
3833  LOGICAL :: nested
3834  INTRINSIC max
3835  INTRINSIC min
3836  is = bd%is
3837  ie = bd%ie
3838  js = bd%js
3839  je = bd%je
3840  npx = flagstruct%npx
3841  npy = flagstruct%npy
3842  nested = gridstruct%nested
3843  sin_sg => gridstruct%sin_sg
3844  cos_sg => gridstruct%cos_sg
3845  dxc => gridstruct%dxc
3846  dyc => gridstruct%dyc
3847  IF (nested) THEN
3848  is2 = is
3849  ie1 = ie + 1
3850  ELSE
3851  IF (2 .LT. is) THEN
3852  is2 = is
3853  ELSE
3854  is2 = 2
3855  END IF
3856  IF (npx - 1 .GT. ie + 1) THEN
3857  ie1 = ie + 1
3858  ELSE
3859  ie1 = npx - 1
3860  END IF
3861  END IF
3862  IF (flagstruct%grid_type .EQ. 4) THEN
3863  uf_tl = 0.0
3864  DO j=js-1,je+2
3865  DO i=is-2,ie+2
3866  uf_tl(i, j) = dyc(i, j)*u_tl(i, j)
3867  uf(i, j) = u(i, j)*dyc(i, j)
3868  END DO
3869  END DO
3870  vf_tl = 0.0
3871  DO j=js-2,je+2
3872  DO i=is-1,ie+2
3873  vf_tl(i, j) = dxc(i, j)*v_tl(i, j)
3874  vf(i, j) = v(i, j)*dxc(i, j)
3875  END DO
3876  END DO
3877  DO j=js-1,je+2
3878  DO i=is-1,ie+2
3879  divg_d_tl(i, j) = gridstruct%rarea_c(i, j)*(vf_tl(i, j-1)-&
3880 & vf_tl(i, j)+uf_tl(i-1, j)-uf_tl(i, j))
3881  divg_d(i, j) = gridstruct%rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(&
3882 & uf(i-1, j)-uf(i, j)))
3883  END DO
3884  END DO
3885  ELSE
3886  uf_tl = 0.0
3887 ! 9---4---8
3888 ! | |
3889 ! 1 5 3
3890 ! | |
3891 ! 6---2---7
3892  DO j=js,je+1
3893  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
3894  DO i=is-1,ie+1
3895  uf_tl(i, j) = dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i, j, &
3896 & 2))*u_tl(i, j)
3897  uf(i, j) = u(i, j)*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i&
3898 & , j, 2))
3899  END DO
3900  ELSE
3901  DO i=is-1,ie+1
3902  uf_tl(i, j) = dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i, j, &
3903 & 2))*(u_tl(i, j)-0.25*(cos_sg(i, j-1, 4)+cos_sg(i, j, 2))*(&
3904 & va_tl(i, j-1)+va_tl(i, j)))
3905  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-&
3906 & 1, 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
3907 & sin_sg(i, j, 2))
3908  END DO
3909  END IF
3910  END DO
3911  vf_tl = 0.0
3912  DO j=js-1,je+1
3913  DO i=is2,ie1
3914  vf_tl(i, j) = dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+sin_sg(i, j, 1)&
3915 & )*(v_tl(i, j)-0.25*(cos_sg(i-1, j, 3)+cos_sg(i, j, 1))*(&
3916 & ua_tl(i-1, j)+ua_tl(i, j)))
3917  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
3918 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
3919 & sin_sg(i, j, 1))
3920  END DO
3921  IF (is .EQ. 1) THEN
3922  vf_tl(1, j) = dxc(1, j)*0.5*(sin_sg(0, j, 3)+sin_sg(1, j, 1))*&
3923 & v_tl(1, j)
3924  vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0, j, 3)+sin_sg(1, j&
3925 & , 1))
3926  END IF
3927  IF (ie + 1 .EQ. npx) THEN
3928  vf_tl(npx, j) = dxc(npx, j)*0.5*(sin_sg(npx-1, j, 3)+sin_sg(&
3929 & npx, j, 1))*v_tl(npx, j)
3930  vf(npx, j) = v(npx, j)*dxc(npx, j)*0.5*(sin_sg(npx-1, j, 3)+&
3931 & sin_sg(npx, j, 1))
3932  END IF
3933  END DO
3934  DO j=js,je+1
3935  DO i=is,ie+1
3936  divg_d_tl(i, j) = vf_tl(i, j-1) - vf_tl(i, j) + uf_tl(i-1, j) &
3937 & - uf_tl(i, j)
3938  divg_d(i, j) = vf(i, j-1) - vf(i, j) + (uf(i-1, j)-uf(i, j))
3939  END DO
3940  END DO
3941 ! Remove the extra term at the corners:
3942  IF (gridstruct%sw_corner) THEN
3943  divg_d_tl(1, 1) = divg_d_tl(1, 1) - vf_tl(1, 0)
3944  divg_d(1, 1) = divg_d(1, 1) - vf(1, 0)
3945  END IF
3946  IF (gridstruct%se_corner) THEN
3947  divg_d_tl(npx, 1) = divg_d_tl(npx, 1) - vf_tl(npx, 0)
3948  divg_d(npx, 1) = divg_d(npx, 1) - vf(npx, 0)
3949  END IF
3950  IF (gridstruct%ne_corner) THEN
3951  divg_d_tl(npx, npy) = divg_d_tl(npx, npy) + vf_tl(npx, npy)
3952  divg_d(npx, npy) = divg_d(npx, npy) + vf(npx, npy)
3953  END IF
3954  IF (gridstruct%nw_corner) THEN
3955  divg_d_tl(1, npy) = divg_d_tl(1, npy) + vf_tl(1, npy)
3956  divg_d(1, npy) = divg_d(1, npy) + vf(1, npy)
3957  END IF
3958  DO j=js,je+1
3959  DO i=is,ie+1
3960  divg_d_tl(i, j) = gridstruct%rarea_c(i, j)*divg_d_tl(i, j)
3961  divg_d(i, j) = gridstruct%rarea_c(i, j)*divg_d(i, j)
3962  END DO
3963  END DO
3964  END IF
3965  END SUBROUTINE divergence_corner_tlm
3966  SUBROUTINE divergence_corner(u, v, ua, va, divg_d, gridstruct, &
3967 & flagstruct, bd)
3968  IMPLICIT NONE
3969  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3970  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
3971  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
3972  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
3973  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
3974 & divg_d
3975  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3976  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
3977 ! local
3978  REAL :: uf(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
3979  REAL :: vf(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
3980  INTEGER :: i, j
3981  INTEGER :: is2, ie1
3982  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
3983  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
3984  INTEGER :: is, ie, js, je
3985  INTEGER :: npx, npy
3986  LOGICAL :: nested
3987  INTRINSIC max
3988  INTRINSIC min
3989  is = bd%is
3990  ie = bd%ie
3991  js = bd%js
3992  je = bd%je
3993  npx = flagstruct%npx
3994  npy = flagstruct%npy
3995  nested = gridstruct%nested
3996  sin_sg => gridstruct%sin_sg
3997  cos_sg => gridstruct%cos_sg
3998  dxc => gridstruct%dxc
3999  dyc => gridstruct%dyc
4000  IF (nested) THEN
4001  is2 = is
4002  ie1 = ie + 1
4003  ELSE
4004  IF (2 .LT. is) THEN
4005  is2 = is
4006  ELSE
4007  is2 = 2
4008  END IF
4009  IF (npx - 1 .GT. ie + 1) THEN
4010  ie1 = ie + 1
4011  ELSE
4012  ie1 = npx - 1
4013  END IF
4014  END IF
4015  IF (flagstruct%grid_type .EQ. 4) THEN
4016  DO j=js-1,je+2
4017  DO i=is-2,ie+2
4018  uf(i, j) = u(i, j)*dyc(i, j)
4019  END DO
4020  END DO
4021  DO j=js-2,je+2
4022  DO i=is-1,ie+2
4023  vf(i, j) = v(i, j)*dxc(i, j)
4024  END DO
4025  END DO
4026  DO j=js-1,je+2
4027  DO i=is-1,ie+2
4028  divg_d(i, j) = gridstruct%rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(&
4029 & uf(i-1, j)-uf(i, j)))
4030  END DO
4031  END DO
4032  ELSE
4033 ! 9---4---8
4034 ! | |
4035 ! 1 5 3
4036 ! | |
4037 ! 6---2---7
4038  DO j=js,je+1
4039  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
4040  DO i=is-1,ie+1
4041  uf(i, j) = u(i, j)*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i&
4042 & , j, 2))
4043  END DO
4044  ELSE
4045  DO i=is-1,ie+1
4046  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-&
4047 & 1, 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
4048 & sin_sg(i, j, 2))
4049  END DO
4050  END IF
4051  END DO
4052  DO j=js-1,je+1
4053  DO i=is2,ie1
4054  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
4055 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
4056 & sin_sg(i, j, 1))
4057  END DO
4058  IF (is .EQ. 1) vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0, j, 3)&
4059 & +sin_sg(1, j, 1))
4060  IF (ie + 1 .EQ. npx) vf(npx, j) = v(npx, j)*dxc(npx, j)*0.5*(&
4061 & sin_sg(npx-1, j, 3)+sin_sg(npx, j, 1))
4062  END DO
4063  DO j=js,je+1
4064  DO i=is,ie+1
4065  divg_d(i, j) = vf(i, j-1) - vf(i, j) + (uf(i-1, j)-uf(i, j))
4066  END DO
4067  END DO
4068 ! Remove the extra term at the corners:
4069  IF (gridstruct%sw_corner) divg_d(1, 1) = divg_d(1, 1) - vf(1, 0)
4070  IF (gridstruct%se_corner) divg_d(npx, 1) = divg_d(npx, 1) - vf(npx&
4071 & , 0)
4072  IF (gridstruct%ne_corner) divg_d(npx, npy) = divg_d(npx, npy) + vf&
4073 & (npx, npy)
4074  IF (gridstruct%nw_corner) divg_d(1, npy) = divg_d(1, npy) + vf(1, &
4075 & npy)
4076  DO j=js,je+1
4077  DO i=is,ie+1
4078  divg_d(i, j) = gridstruct%rarea_c(i, j)*divg_d(i, j)
4079  END DO
4080  END DO
4081  END IF
4082  END SUBROUTINE divergence_corner
4083 ! Differentiation of divergence_corner_nest in forward (tangent) mode:
4084 ! variations of useful results: divg_d
4085 ! with respect to varying inputs: u v ua va
4086  SUBROUTINE divergence_corner_nest_tlm(u, u_tl, v, v_tl, ua, ua_tl, va&
4087 & , va_tl, divg_d, divg_d_tl, gridstruct, flagstruct, bd)
4088  IMPLICIT NONE
4089 !!$ !Edges
4090 !!$
4091 !!$ !West, East
4092 !!$ do j=jsd+1,jed
4093 !!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j)
4094 !!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j)
4095 !!$ end do
4096 !!$
4097 !!$ !North, South
4098 !!$ do i=isd+1,ied
4099 !!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd)
4100 !!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed)
4101 !!$ end do
4102 !!$
4103 !!$ !Corners (just use next corner value)
4104 !!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1)
4105 !!$ divg_d(isd,jed+1) = divg_d(isd+1,jed)
4106 !!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1)
4107 !!$ divg_d(ied+1,jed+1) = divg_d(ied,jed)
4108  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
4109  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
4110  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u_tl
4111  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
4112  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v_tl
4113  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
4114  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua_tl, &
4115 & va_tl
4116  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
4117 & divg_d
4118  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
4119 & divg_d_tl
4120  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
4121  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
4122 ! local
4123  REAL :: uf(bd%isd:bd%ied, bd%jsd:bd%jed+1)
4124  REAL :: uf_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1)
4125  REAL :: vf(bd%isd:bd%ied+1, bd%jsd:bd%jed)
4126  REAL :: vf_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed)
4127  INTEGER :: i, j
4128  REAL, DIMENSION(:, :), POINTER :: rarea_c
4129  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
4130  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
4131  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
4132  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
4133  INTEGER :: isd, ied, jsd, jed
4134  INTEGER :: npx, npy
4135  LOGICAL :: nested
4136  isd = bd%isd
4137  ied = bd%ied
4138  jsd = bd%jsd
4139  jed = bd%jed
4140  npx = flagstruct%npx
4141  npy = flagstruct%npy
4142  nested = gridstruct%nested
4143  rarea_c => gridstruct%rarea_c
4144  sin_sg => gridstruct%sin_sg
4145  cos_sg => gridstruct%cos_sg
4146  cosa_u => gridstruct%cosa_u
4147  cosa_v => gridstruct%cosa_v
4148  sina_u => gridstruct%sina_u
4149  sina_v => gridstruct%sina_v
4150  dxc => gridstruct%dxc
4151  dyc => gridstruct%dyc
4152  divg_d = 1.e25
4153  IF (flagstruct%grid_type .EQ. 4) THEN
4154  uf_tl = 0.0
4155  DO j=jsd,jed
4156  DO i=isd,ied
4157  uf_tl(i, j) = dyc(i, j)*u_tl(i, j)
4158  uf(i, j) = u(i, j)*dyc(i, j)
4159  END DO
4160  END DO
4161  vf_tl = 0.0
4162  DO j=jsd,jed
4163  DO i=isd,ied
4164  vf_tl(i, j) = dxc(i, j)*v_tl(i, j)
4165  vf(i, j) = v(i, j)*dxc(i, j)
4166  END DO
4167  END DO
4168  divg_d_tl = 0.0
4169  DO j=jsd+1,jed
4170  DO i=isd+1,ied
4171  divg_d_tl(i, j) = rarea_c(i, j)*(vf_tl(i, j-1)-vf_tl(i, j)+&
4172 & uf_tl(i-1, j)-uf_tl(i, j))
4173  divg_d(i, j) = rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(uf(i-1, j)-&
4174 & uf(i, j)))
4175  END DO
4176  END DO
4177  ELSE
4178  uf_tl = 0.0
4179  DO j=jsd+1,jed
4180  DO i=isd,ied
4181  uf_tl(i, j) = dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i, j, 2)&
4182 & )*(u_tl(i, j)-0.25*(cos_sg(i, j-1, 4)+cos_sg(i, j, 2))*(&
4183 & va_tl(i, j-1)+va_tl(i, j)))
4184  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-1&
4185 & , 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
4186 & sin_sg(i, j, 2))
4187  END DO
4188  END DO
4189  vf_tl = 0.0
4190  DO j=jsd,jed
4191  DO i=isd+1,ied
4192  vf_tl(i, j) = dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+sin_sg(i, j, 1)&
4193 & )*(v_tl(i, j)-0.25*(cos_sg(i-1, j, 3)+cos_sg(i, j, 1))*(&
4194 & ua_tl(i-1, j)+ua_tl(i, j)))
4195  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
4196 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
4197 & sin_sg(i, j, 1))
4198  END DO
4199  END DO
4200  divg_d_tl = 0.0
4201  DO j=jsd+1,jed
4202  DO i=isd+1,ied
4203  divg_d_tl(i, j) = rarea_c(i, j)*(vf_tl(i, j-1)-vf_tl(i, j)+&
4204 & uf_tl(i-1, j)-uf_tl(i, j))
4205  divg_d(i, j) = (vf(i, j-1)-vf(i, j)+(uf(i-1, j)-uf(i, j)))*&
4206 & rarea_c(i, j)
4207  END DO
4208  END DO
4209  END IF
4210  END SUBROUTINE divergence_corner_nest_tlm
4211  SUBROUTINE divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, &
4212 & flagstruct, bd)
4213  IMPLICIT NONE
4214 !!$ !Edges
4215 !!$
4216 !!$ !West, East
4217 !!$ do j=jsd+1,jed
4218 !!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j)
4219 !!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j)
4220 !!$ end do
4221 !!$
4222 !!$ !North, South
4223 !!$ do i=isd+1,ied
4224 !!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd)
4225 !!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed)
4226 !!$ end do
4227 !!$
4228 !!$ !Corners (just use next corner value)
4229 !!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1)
4230 !!$ divg_d(isd,jed+1) = divg_d(isd+1,jed)
4231 !!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1)
4232 !!$ divg_d(ied+1,jed+1) = divg_d(ied,jed)
4233  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
4234  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
4235  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
4236  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
4237  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
4238 & divg_d
4239  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
4240  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
4241 ! local
4242  REAL :: uf(bd%isd:bd%ied, bd%jsd:bd%jed+1)
4243  REAL :: vf(bd%isd:bd%ied+1, bd%jsd:bd%jed)
4244  INTEGER :: i, j
4245  REAL, DIMENSION(:, :), POINTER :: rarea_c
4246  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
4247  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
4248  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
4249  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
4250  INTEGER :: isd, ied, jsd, jed
4251  INTEGER :: npx, npy
4252  LOGICAL :: nested
4253  isd = bd%isd
4254  ied = bd%ied
4255  jsd = bd%jsd
4256  jed = bd%jed
4257  npx = flagstruct%npx
4258  npy = flagstruct%npy
4259  nested = gridstruct%nested
4260  rarea_c => gridstruct%rarea_c
4261  sin_sg => gridstruct%sin_sg
4262  cos_sg => gridstruct%cos_sg
4263  cosa_u => gridstruct%cosa_u
4264  cosa_v => gridstruct%cosa_v
4265  sina_u => gridstruct%sina_u
4266  sina_v => gridstruct%sina_v
4267  dxc => gridstruct%dxc
4268  dyc => gridstruct%dyc
4269  divg_d = 1.e25
4270  IF (flagstruct%grid_type .EQ. 4) THEN
4271  DO j=jsd,jed
4272  DO i=isd,ied
4273  uf(i, j) = u(i, j)*dyc(i, j)
4274  END DO
4275  END DO
4276  DO j=jsd,jed
4277  DO i=isd,ied
4278  vf(i, j) = v(i, j)*dxc(i, j)
4279  END DO
4280  END DO
4281  DO j=jsd+1,jed
4282  DO i=isd+1,ied
4283  divg_d(i, j) = rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(uf(i-1, j)-&
4284 & uf(i, j)))
4285  END DO
4286  END DO
4287  ELSE
4288  DO j=jsd+1,jed
4289  DO i=isd,ied
4290  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-1&
4291 & , 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
4292 & sin_sg(i, j, 2))
4293  END DO
4294  END DO
4295  DO j=jsd,jed
4296  DO i=isd+1,ied
4297  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
4298 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
4299 & sin_sg(i, j, 1))
4300  END DO
4301  END DO
4302  DO j=jsd+1,jed
4303  DO i=isd+1,ied
4304  divg_d(i, j) = (vf(i, j-1)-vf(i, j)+(uf(i-1, j)-uf(i, j)))*&
4305 & rarea_c(i, j)
4306  END DO
4307  END DO
4308  END IF
4309  END SUBROUTINE divergence_corner_nest
4310  SUBROUTINE xtp_u(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, &
4311 & iord, dx, rdx, npx, npy, grid_type, nested)
4312  IMPLICIT NONE
4313  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
4314  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
4315  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
4316  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
4317  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
4318  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
4319  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
4320  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
4321  LOGICAL, INTENT(IN) :: nested
4322 ! Local
4323  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
4324  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
4325  REAL :: fx0(is:ie+1)
4326  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
4327  REAL :: dq(is-3:ie+2)
4328  REAL :: dl, dr, xt, pmp, lac, cfl
4329  REAL :: pmp_1, lac_1, pmp_2, lac_2
4330  REAL :: x0, x1, x0l, x0r
4331  INTEGER :: i, j
4332  INTEGER :: is3, ie3
4333  INTEGER :: is2, ie2
4334  INTRINSIC max
4335  INTRINSIC min
4336  INTRINSIC abs
4337  INTRINSIC sign
4338  REAL :: min1
4339  REAL :: min2
4340  REAL :: abs0
4341  REAL :: min3
4342  REAL :: min4
4343  REAL :: min5
4344  REAL :: abs1
4345  REAL :: abs2
4346  REAL :: abs3
4347  REAL :: abs4
4348  REAL :: max1
4349  REAL :: min6
4350  REAL :: abs5
4351  REAL :: abs6
4352  REAL :: x12
4353  REAL :: x11
4354  REAL :: x10
4355  REAL :: x9
4356  REAL :: x8
4357  REAL :: x7
4358  REAL :: x6
4359  REAL :: x5
4360  REAL :: x4
4361  REAL :: x3
4362  REAL :: x2
4363  REAL :: y17
4364  REAL :: y16
4365  REAL :: y15
4366  REAL :: y14
4367  REAL :: y13
4368  REAL :: y12
4369  REAL :: y11
4370  REAL :: y10
4371  REAL :: z1
4372  REAL :: y9
4373  REAL :: y8
4374  REAL :: y7
4375  REAL :: y6
4376  REAL :: y5
4377  REAL :: y4
4378  REAL :: y3
4379  REAL :: y2
4380  REAL :: y1
4381  IF (nested .OR. grid_type .GT. 3) THEN
4382  is3 = is - 1
4383  ie3 = ie + 1
4384  ELSE
4385  IF (3 .LT. is - 1) THEN
4386  is3 = is - 1
4387  ELSE
4388  is3 = 3
4389  END IF
4390  IF (npx - 3 .GT. ie + 1) THEN
4391  ie3 = ie + 1
4392  ELSE
4393  ie3 = npx - 3
4394  END IF
4395  END IF
4396  IF (iord .EQ. 1) THEN
4397  DO j=js,je+1
4398  DO i=is,ie+1
4399  IF (c(i, j) .GT. 0.) THEN
4400  flux(i, j) = u(i-1, j)
4401  ELSE
4402  flux(i, j) = u(i, j)
4403  END IF
4404  END DO
4405  END DO
4406  ELSE IF (iord .LT. 8) THEN
4407 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
4408  DO j=js,je+1
4409  DO i=is3,ie3+1
4410  al(i) = p1*(u(i-1, j)+u(i, j)) + p2*(u(i-2, j)+u(i+1, j))
4411  END DO
4412  DO i=is3,ie3
4413  bl(i) = al(i) - u(i, j)
4414  br(i) = al(i+1) - u(i, j)
4415  END DO
4416  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
4417  IF (is .EQ. 1) THEN
4418  xt = c3*u(1, j) + c2*u(2, j) + c1*u(3, j)
4419  br(1) = xt - u(1, j)
4420  bl(2) = xt - u(2, j)
4421  br(2) = al(3) - u(2, j)
4422  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
4423 ! out
4424  bl(0) = 0.
4425 ! edge
4426  br(0) = 0.
4427 ! edge
4428  bl(1) = 0.
4429 ! in
4430  br(1) = 0.
4431  ELSE
4432  bl(0) = c1*u(-2, j) + c2*u(-1, j) + c3*u(0, j) - u(0, j)
4433  xt = 0.5*(((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
4434 & j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j))*u(1, j)&
4435 & -dx(1, j)*u(2, j))/(dx(1, j)+dx(2, j)))
4436  br(0) = xt - u(0, j)
4437  bl(1) = xt - u(1, j)
4438  END IF
4439  END IF
4440 ! call pert_ppm(1, u(2,j), bl(2), br(2), -1)
4441  IF (ie + 1 .EQ. npx) THEN
4442  bl(npx-2) = al(npx-2) - u(npx-2, j)
4443  xt = c1*u(npx-3, j) + c2*u(npx-2, j) + c3*u(npx-1, j)
4444  br(npx-2) = xt - u(npx-2, j)
4445  bl(npx-1) = xt - u(npx-1, j)
4446  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
4447 ! in
4448  bl(npx-1) = 0.
4449 ! edge
4450  br(npx-1) = 0.
4451 ! edge
4452  bl(npx) = 0.
4453 ! out
4454  br(npx) = 0.
4455  ELSE
4456  xt = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
4457 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))+((2.*&
4458 & dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, j)*u(npx+1, j&
4459 & ))/(dx(npx, j)+dx(npx+1, j)))
4460  br(npx-1) = xt - u(npx-1, j)
4461  bl(npx) = xt - u(npx, j)
4462  br(npx) = c3*u(npx, j) + c2*u(npx+1, j) + c1*u(npx+2, j) -&
4463 & u(npx, j)
4464  END IF
4465  END IF
4466  END IF
4467 ! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
4468  DO i=is-1,ie+1
4469  b0(i) = bl(i) + br(i)
4470  END DO
4471  IF (iord .EQ. 2) THEN
4472 ! Perfectly linear
4473 !DEC$ VECTOR ALWAYS
4474  DO i=is,ie+1
4475  IF (c(i, j) .GT. 0.) THEN
4476  cfl = c(i, j)*rdx(i-1, j)
4477  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
4478  ELSE
4479  cfl = c(i, j)*rdx(i, j)
4480  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
4481  END IF
4482  END DO
4483  ELSE IF (iord .EQ. 3) THEN
4484  DO i=is-1,ie+1
4485  IF (b0(i) .GE. 0.) THEN
4486  x0 = b0(i)
4487  ELSE
4488  x0 = -b0(i)
4489  END IF
4490  IF (bl(i) - br(i) .GE. 0.) THEN
4491  x1 = bl(i) - br(i)
4492  ELSE
4493  x1 = -(bl(i)-br(i))
4494  END IF
4495  smt5(i) = x0 .LT. x1
4496  smt6(i) = 3.*x0 .LT. x1
4497  END DO
4498  DO i=is,ie+1
4499  fx0(i) = 0.
4500  END DO
4501  DO i=is,ie+1
4502  IF (c(i, j) .GT. 0.) THEN
4503  cfl = c(i, j)*rdx(i-1, j)
4504  IF (smt6(i-1) .OR. smt5(i)) THEN
4505  fx0(i) = br(i-1) - cfl*b0(i-1)
4506  ELSE IF (smt5(i-1)) THEN
4507  IF (bl(i-1) .GE. 0.) THEN
4508  x2 = bl(i-1)
4509  ELSE
4510  x2 = -bl(i-1)
4511  END IF
4512  IF (br(i-1) .GE. 0.) THEN
4513  y1 = br(i-1)
4514  ELSE
4515  y1 = -br(i-1)
4516  END IF
4517  IF (x2 .GT. y1) THEN
4518  min1 = y1
4519  ELSE
4520  min1 = x2
4521  END IF
4522  fx0(i) = sign(min1, br(i-1))
4523  END IF
4524  flux(i, j) = u(i-1, j) + (1.-cfl)*fx0(i)
4525  ELSE
4526  cfl = c(i, j)*rdx(i, j)
4527  IF (smt6(i) .OR. smt5(i-1)) THEN
4528  fx0(i) = bl(i) + cfl*b0(i)
4529  ELSE IF (smt5(i)) THEN
4530  IF (bl(i) .GE. 0.) THEN
4531  x3 = bl(i)
4532  ELSE
4533  x3 = -bl(i)
4534  END IF
4535  IF (br(i) .GE. 0.) THEN
4536  y2 = br(i)
4537  ELSE
4538  y2 = -br(i)
4539  END IF
4540  IF (x3 .GT. y2) THEN
4541  min2 = y2
4542  ELSE
4543  min2 = x3
4544  END IF
4545  fx0(i) = sign(min2, bl(i))
4546  END IF
4547  flux(i, j) = u(i, j) + (1.+cfl)*fx0(i)
4548  END IF
4549  END DO
4550  ELSE IF (iord .EQ. 4) THEN
4551 ! more damp than ord5 but less damp than ord6
4552  DO i=is-1,ie+1
4553  IF (b0(i) .GE. 0.) THEN
4554  x0 = b0(i)
4555  ELSE
4556  x0 = -b0(i)
4557  END IF
4558  IF (bl(i) - br(i) .GE. 0.) THEN
4559  x1 = bl(i) - br(i)
4560  ELSE
4561  x1 = -(bl(i)-br(i))
4562  END IF
4563  smt5(i) = x0 .LT. x1
4564 ! if smt6 =.T. --> smt5=.T.
4565  smt6(i) = 3.*x0 .LT. x1
4566  END DO
4567  DO i=is,ie+1
4568  IF (c(i, j) .GT. 0.) THEN
4569  IF (smt6(i-1) .OR. smt5(i)) THEN
4570  cfl = c(i, j)*rdx(i-1, j)
4571  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
4572  ELSE
4573 ! 1st order ONLY_IF smt6(i-1)=.F. .AND. smt5(i)=.F.
4574  flux(i, j) = u(i-1, j)
4575  END IF
4576  ELSE IF (smt6(i) .OR. smt5(i-1)) THEN
4577  cfl = c(i, j)*rdx(i, j)
4578  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
4579  ELSE
4580  flux(i, j) = u(i, j)
4581  END IF
4582  END DO
4583  ELSE
4584 ! iord=5,6,7
4585  IF (iord .EQ. 5) THEN
4586  DO i=is-1,ie+1
4587  smt5(i) = bl(i)*br(i) .LT. 0.
4588  END DO
4589  ELSE
4590  DO i=is-1,ie+1
4591  IF (3.*b0(i) .GE. 0.) THEN
4592  abs0 = 3.*b0(i)
4593  ELSE
4594  abs0 = -(3.*b0(i))
4595  END IF
4596  IF (bl(i) - br(i) .GE. 0.) THEN
4597  abs4 = bl(i) - br(i)
4598  ELSE
4599  abs4 = -(bl(i)-br(i))
4600  END IF
4601  smt5(i) = abs0 .LT. abs4
4602  END DO
4603  END IF
4604 !DEC$ VECTOR ALWAYS
4605  DO i=is,ie+1
4606  IF (c(i, j) .GT. 0.) THEN
4607  cfl = c(i, j)*rdx(i-1, j)
4608  fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1))
4609  flux(i, j) = u(i-1, j)
4610  ELSE
4611  cfl = c(i, j)*rdx(i, j)
4612  fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i))
4613  flux(i, j) = u(i, j)
4614  END IF
4615  IF (smt5(i-1) .OR. smt5(i)) flux(i, j) = flux(i, j) + fx0(i)
4616  END DO
4617  END IF
4618  END DO
4619  ELSE
4620 ! iord = 8, 9, 10, 11
4621  DO j=js,je+1
4622  DO i=is-2,ie+2
4623  xt = 0.25*(u(i+1, j)-u(i-1, j))
4624  IF (xt .GE. 0.) THEN
4625  x4 = xt
4626  ELSE
4627  x4 = -xt
4628  END IF
4629  IF (u(i-1, j) .LT. u(i, j)) THEN
4630  IF (u(i, j) .LT. u(i+1, j)) THEN
4631  max1 = u(i+1, j)
4632  ELSE
4633  max1 = u(i, j)
4634  END IF
4635  ELSE IF (u(i-1, j) .LT. u(i+1, j)) THEN
4636  max1 = u(i+1, j)
4637  ELSE
4638  max1 = u(i-1, j)
4639  END IF
4640  y3 = max1 - u(i, j)
4641  IF (u(i-1, j) .GT. u(i, j)) THEN
4642  IF (u(i, j) .GT. u(i+1, j)) THEN
4643  min6 = u(i+1, j)
4644  ELSE
4645  min6 = u(i, j)
4646  END IF
4647  ELSE IF (u(i-1, j) .GT. u(i+1, j)) THEN
4648  min6 = u(i+1, j)
4649  ELSE
4650  min6 = u(i-1, j)
4651  END IF
4652  z1 = u(i, j) - min6
4653  IF (x4 .GT. y3) THEN
4654  IF (y3 .GT. z1) THEN
4655  min3 = z1
4656  ELSE
4657  min3 = y3
4658  END IF
4659  ELSE IF (x4 .GT. z1) THEN
4660  min3 = z1
4661  ELSE
4662  min3 = x4
4663  END IF
4664  dm(i) = sign(min3, xt)
4665  END DO
4666  DO i=is-3,ie+2
4667  dq(i) = u(i+1, j) - u(i, j)
4668  END DO
4669  IF (grid_type .LT. 3) THEN
4670  DO i=is3,ie3+1
4671  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
4672  END DO
4673 ! Perturbation form:
4674  IF (iord .EQ. 8) THEN
4675  DO i=is3,ie3
4676  xt = 2.*dm(i)
4677  IF (xt .GE. 0.) THEN
4678  x5 = xt
4679  ELSE
4680  x5 = -xt
4681  END IF
4682  IF (al(i) - u(i, j) .GE. 0.) THEN
4683  y4 = al(i) - u(i, j)
4684  ELSE
4685  y4 = -(al(i)-u(i, j))
4686  END IF
4687  IF (x5 .GT. y4) THEN
4688  min4 = y4
4689  ELSE
4690  min4 = x5
4691  END IF
4692  bl(i) = -sign(min4, xt)
4693  IF (xt .GE. 0.) THEN
4694  x6 = xt
4695  ELSE
4696  x6 = -xt
4697  END IF
4698  IF (al(i+1) - u(i, j) .GE. 0.) THEN
4699  y5 = al(i+1) - u(i, j)
4700  ELSE
4701  y5 = -(al(i+1)-u(i, j))
4702  END IF
4703  IF (x6 .GT. y5) THEN
4704  min5 = y5
4705  ELSE
4706  min5 = x6
4707  END IF
4708  br(i) = sign(min5, xt)
4709  END DO
4710  ELSE IF (iord .EQ. 9) THEN
4711  DO i=is3,ie3
4712  pmp_1 = -(2.*dq(i))
4713  lac_1 = pmp_1 + 1.5*dq(i+1)
4714  IF (0. .LT. pmp_1) THEN
4715  IF (pmp_1 .LT. lac_1) THEN
4716  x7 = lac_1
4717  ELSE
4718  x7 = pmp_1
4719  END IF
4720  ELSE IF (0. .LT. lac_1) THEN
4721  x7 = lac_1
4722  ELSE
4723  x7 = 0.
4724  END IF
4725  IF (0. .GT. pmp_1) THEN
4726  IF (pmp_1 .GT. lac_1) THEN
4727  y12 = lac_1
4728  ELSE
4729  y12 = pmp_1
4730  END IF
4731  ELSE IF (0. .GT. lac_1) THEN
4732  y12 = lac_1
4733  ELSE
4734  y12 = 0.
4735  END IF
4736  IF (al(i) - u(i, j) .LT. y12) THEN
4737  y6 = y12
4738  ELSE
4739  y6 = al(i) - u(i, j)
4740  END IF
4741  IF (x7 .GT. y6) THEN
4742  bl(i) = y6
4743  ELSE
4744  bl(i) = x7
4745  END IF
4746  pmp_2 = 2.*dq(i-1)
4747  lac_2 = pmp_2 - 1.5*dq(i-2)
4748  IF (0. .LT. pmp_2) THEN
4749  IF (pmp_2 .LT. lac_2) THEN
4750  x8 = lac_2
4751  ELSE
4752  x8 = pmp_2
4753  END IF
4754  ELSE IF (0. .LT. lac_2) THEN
4755  x8 = lac_2
4756  ELSE
4757  x8 = 0.
4758  END IF
4759  IF (0. .GT. pmp_2) THEN
4760  IF (pmp_2 .GT. lac_2) THEN
4761  y13 = lac_2
4762  ELSE
4763  y13 = pmp_2
4764  END IF
4765  ELSE IF (0. .GT. lac_2) THEN
4766  y13 = lac_2
4767  ELSE
4768  y13 = 0.
4769  END IF
4770  IF (al(i+1) - u(i, j) .LT. y13) THEN
4771  y7 = y13
4772  ELSE
4773  y7 = al(i+1) - u(i, j)
4774  END IF
4775  IF (x8 .GT. y7) THEN
4776  br(i) = y7
4777  ELSE
4778  br(i) = x8
4779  END IF
4780  END DO
4781  ELSE IF (iord .EQ. 10) THEN
4782  DO i=is3,ie3
4783  bl(i) = al(i) - u(i, j)
4784  br(i) = al(i+1) - u(i, j)
4785  IF (dm(i) .GE. 0.) THEN
4786  abs1 = dm(i)
4787  ELSE
4788  abs1 = -dm(i)
4789  END IF
4790 ! if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then
4791  IF (abs1 .LT. near_zero) THEN
4792  IF (dm(i-1) .GE. 0.) THEN
4793  abs2 = dm(i-1)
4794  ELSE
4795  abs2 = -dm(i-1)
4796  END IF
4797  IF (dm(i+1) .GE. 0.) THEN
4798  abs5 = dm(i+1)
4799  ELSE
4800  abs5 = -dm(i+1)
4801  END IF
4802  IF (abs2 + abs5 .LT. near_zero) THEN
4803 ! 2-delta-x structure detected within 3 cells
4804  bl(i) = 0.
4805  br(i) = 0.
4806  END IF
4807  ELSE
4808  IF (3.*(bl(i)+br(i)) .GE. 0.) THEN
4809  abs3 = 3.*(bl(i)+br(i))
4810  ELSE
4811  abs3 = -(3.*(bl(i)+br(i)))
4812  END IF
4813  IF (bl(i) - br(i) .GE. 0.) THEN
4814  abs6 = bl(i) - br(i)
4815  ELSE
4816  abs6 = -(bl(i)-br(i))
4817  END IF
4818  IF (abs3 .GT. abs6) THEN
4819  pmp_1 = -(2.*dq(i))
4820  lac_1 = pmp_1 + 1.5*dq(i+1)
4821  IF (0. .LT. pmp_1) THEN
4822  IF (pmp_1 .LT. lac_1) THEN
4823  x9 = lac_1
4824  ELSE
4825  x9 = pmp_1
4826  END IF
4827  ELSE IF (0. .LT. lac_1) THEN
4828  x9 = lac_1
4829  ELSE
4830  x9 = 0.
4831  END IF
4832  IF (0. .GT. pmp_1) THEN
4833  IF (pmp_1 .GT. lac_1) THEN
4834  y14 = lac_1
4835  ELSE
4836  y14 = pmp_1
4837  END IF
4838  ELSE IF (0. .GT. lac_1) THEN
4839  y14 = lac_1
4840  ELSE
4841  y14 = 0.
4842  END IF
4843  IF (bl(i) .LT. y14) THEN
4844  y8 = y14
4845  ELSE
4846  y8 = bl(i)
4847  END IF
4848  IF (x9 .GT. y8) THEN
4849  bl(i) = y8
4850  ELSE
4851  bl(i) = x9
4852  END IF
4853  pmp_2 = 2.*dq(i-1)
4854  lac_2 = pmp_2 - 1.5*dq(i-2)
4855  IF (0. .LT. pmp_2) THEN
4856  IF (pmp_2 .LT. lac_2) THEN
4857  x10 = lac_2
4858  ELSE
4859  x10 = pmp_2
4860  END IF
4861  ELSE IF (0. .LT. lac_2) THEN
4862  x10 = lac_2
4863  ELSE
4864  x10 = 0.
4865  END IF
4866  IF (0. .GT. pmp_2) THEN
4867  IF (pmp_2 .GT. lac_2) THEN
4868  y15 = lac_2
4869  ELSE
4870  y15 = pmp_2
4871  END IF
4872  ELSE IF (0. .GT. lac_2) THEN
4873  y15 = lac_2
4874  ELSE
4875  y15 = 0.
4876  END IF
4877  IF (br(i) .LT. y15) THEN
4878  y9 = y15
4879  ELSE
4880  y9 = br(i)
4881  END IF
4882  IF (x10 .GT. y9) THEN
4883  br(i) = y9
4884  ELSE
4885  br(i) = x10
4886  END IF
4887  END IF
4888  END IF
4889  END DO
4890  ELSE
4891 ! un-limited: 11
4892  DO i=is3,ie3
4893  bl(i) = al(i) - u(i, j)
4894  br(i) = al(i+1) - u(i, j)
4895  END DO
4896  END IF
4897 !--------------
4898 ! fix the edges
4899 !--------------
4900 !!! TO DO: separate versions for nested and for cubed-sphere
4901  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
4902  br(2) = al(3) - u(2, j)
4903  xt = s15*u(1, j) + s11*u(2, j) - s14*dm(2)
4904  bl(2) = xt - u(2, j)
4905  br(1) = xt - u(1, j)
4906  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
4907 ! out
4908  bl(0) = 0.
4909 ! edge
4910  br(0) = 0.
4911 ! edge
4912  bl(1) = 0.
4913 ! in
4914  br(1) = 0.
4915  ELSE
4916  bl(0) = s14*dm(-1) - s11*dq(-1)
4917  x0l = 0.5*((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
4918 & j))/(dx(0, j)+dx(-1, j))
4919  x0r = 0.5*((2.*dx(1, j)+dx(2, j))*u(1, j)-dx(1, j)*u(2, j)&
4920 & )/(dx(1, j)+dx(2, j))
4921  xt = x0l + x0r
4922  br(0) = xt - u(0, j)
4923  bl(1) = xt - u(1, j)
4924  END IF
4925  CALL pert_ppm(1, u(2:2, j), bl(2:2), br(2:2), -1)
4926  END IF
4927  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
4928  bl(npx-2) = al(npx-2) - u(npx-2, j)
4929  xt = s15*u(npx-1, j) + s11*u(npx-2, j) + s14*dm(npx-2)
4930  br(npx-2) = xt - u(npx-2, j)
4931  bl(npx-1) = xt - u(npx-1, j)
4932  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
4933 ! in
4934  bl(npx-1) = 0.
4935 ! edge
4936  br(npx-1) = 0.
4937 ! edge
4938  bl(npx) = 0.
4939 ! out
4940  br(npx) = 0.
4941  ELSE
4942  br(npx) = s11*dq(npx) - s14*dm(npx+1)
4943  x0l = 0.5*((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
4944 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))
4945  x0r = 0.5*((2.*dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, &
4946 & j)*u(npx+1, j))/(dx(npx, j)+dx(npx+1, j))
4947  xt = x0l + x0r
4948  br(npx-1) = xt - u(npx-1, j)
4949  bl(npx) = xt - u(npx, j)
4950  END IF
4951  CALL pert_ppm(1, u(npx-2:npx-2, j), bl(npx-2:npx-2), br(npx-&
4952 & 2:npx-2), -1)
4953  END IF
4954  ELSE
4955 ! Other grids:
4956  DO i=is-1,ie+2
4957  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
4958  END DO
4959  DO i=is-1,ie+1
4960  pmp = -(2.*dq(i))
4961  lac = pmp + 1.5*dq(i+1)
4962  IF (0. .LT. pmp) THEN
4963  IF (pmp .LT. lac) THEN
4964  x11 = lac
4965  ELSE
4966  x11 = pmp
4967  END IF
4968  ELSE IF (0. .LT. lac) THEN
4969  x11 = lac
4970  ELSE
4971  x11 = 0.
4972  END IF
4973  IF (0. .GT. pmp) THEN
4974  IF (pmp .GT. lac) THEN
4975  y16 = lac
4976  ELSE
4977  y16 = pmp
4978  END IF
4979  ELSE IF (0. .GT. lac) THEN
4980  y16 = lac
4981  ELSE
4982  y16 = 0.
4983  END IF
4984  IF (al(i) - u(i, j) .LT. y16) THEN
4985  y10 = y16
4986  ELSE
4987  y10 = al(i) - u(i, j)
4988  END IF
4989  IF (x11 .GT. y10) THEN
4990  bl(i) = y10
4991  ELSE
4992  bl(i) = x11
4993  END IF
4994  pmp = 2.*dq(i-1)
4995  lac = pmp - 1.5*dq(i-2)
4996  IF (0. .LT. pmp) THEN
4997  IF (pmp .LT. lac) THEN
4998  x12 = lac
4999  ELSE
5000  x12 = pmp
5001  END IF
5002  ELSE IF (0. .LT. lac) THEN
5003  x12 = lac
5004  ELSE
5005  x12 = 0.
5006  END IF
5007  IF (0. .GT. pmp) THEN
5008  IF (pmp .GT. lac) THEN
5009  y17 = lac
5010  ELSE
5011  y17 = pmp
5012  END IF
5013  ELSE IF (0. .GT. lac) THEN
5014  y17 = lac
5015  ELSE
5016  y17 = 0.
5017  END IF
5018  IF (al(i+1) - u(i, j) .LT. y17) THEN
5019  y11 = y17
5020  ELSE
5021  y11 = al(i+1) - u(i, j)
5022  END IF
5023  IF (x12 .GT. y11) THEN
5024  br(i) = y11
5025  ELSE
5026  br(i) = x12
5027  END IF
5028  END DO
5029  END IF
5030  DO i=is,ie+1
5031  IF (c(i, j) .GT. 0.) THEN
5032  cfl = c(i, j)*rdx(i-1, j)
5033  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i&
5034 & -1)))
5035  ELSE
5036  cfl = c(i, j)*rdx(i, j)
5037  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*(bl(i)+br(i)))
5038  END IF
5039  END DO
5040  END DO
5041  END IF
5042  END SUBROUTINE xtp_u
5043  SUBROUTINE ytp_v(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, &
5044 & jord, dy, rdy, npx, npy, grid_type, nested)
5045  IMPLICIT NONE
5046  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
5047  INTEGER, INTENT(IN) :: jord
5048  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
5049  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
5050 ! Courant N (like FLUX)
5051  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
5052  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
5053  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
5054  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
5055  INTEGER, INTENT(IN) :: npx, npy, grid_type
5056  LOGICAL, INTENT(IN) :: nested
5057 ! Local:
5058  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
5059  REAL :: fx0(is:ie+1)
5060  REAL :: dm(is:ie+1, js-2:je+2)
5061  REAL :: al(is:ie+1, js-1:je+2)
5062  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
5063  REAL :: dq(is:ie+1, js-3:je+2)
5064  REAL :: xt, dl, dr, pmp, lac, cfl
5065  REAL :: pmp_1, lac_1, pmp_2, lac_2
5066  REAL :: x0, x1, x0r, x0l
5067  INTEGER :: i, j, is1, ie1, js3, je3
5068  INTRINSIC max
5069  INTRINSIC min
5070  INTRINSIC abs
5071  INTRINSIC sign
5072  REAL :: min1
5073  REAL :: min2
5074  REAL :: abs0
5075  REAL :: min3
5076  REAL :: min4
5077  REAL :: min5
5078  REAL :: abs1
5079  REAL :: abs2
5080  REAL :: abs3
5081  REAL :: abs4
5082  REAL :: max1
5083  REAL :: min6
5084  REAL :: abs5
5085  REAL :: abs6
5086  REAL :: x12
5087  REAL :: x11
5088  REAL :: x10
5089  REAL :: x9
5090  REAL :: x8
5091  REAL :: x7
5092  REAL :: x6
5093  REAL :: x5
5094  REAL :: x4
5095  REAL :: x3
5096  REAL :: x2
5097  REAL :: y17
5098  REAL :: y16
5099  REAL :: y15
5100  REAL :: y14
5101  REAL :: y13
5102  REAL :: y12
5103  REAL :: y11
5104  REAL :: y10
5105  REAL :: z1
5106  REAL :: y9
5107  REAL :: y8
5108  REAL :: y7
5109  REAL :: y6
5110  REAL :: y5
5111  REAL :: y4
5112  REAL :: y3
5113  REAL :: y2
5114  REAL :: y1
5115  IF (nested .OR. grid_type .GT. 3) THEN
5116  js3 = js - 1
5117  je3 = je + 1
5118  ELSE
5119  IF (3 .LT. js - 1) THEN
5120  js3 = js - 1
5121  ELSE
5122  js3 = 3
5123  END IF
5124  IF (npy - 3 .GT. je + 1) THEN
5125  je3 = je + 1
5126  ELSE
5127  je3 = npy - 3
5128  END IF
5129  END IF
5130  IF (jord .EQ. 1) THEN
5131  DO j=js,je+1
5132  DO i=is,ie+1
5133  IF (c(i, j) .GT. 0.) THEN
5134  flux(i, j) = v(i, j-1)
5135  ELSE
5136  flux(i, j) = v(i, j)
5137  END IF
5138  END DO
5139  END DO
5140  ELSE IF (jord .LT. 8) THEN
5141 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
5142  DO j=js3,je3+1
5143  DO i=is,ie+1
5144  al(i, j) = p1*(v(i, j-1)+v(i, j)) + p2*(v(i, j-2)+v(i, j+1))
5145  END DO
5146  END DO
5147  DO j=js3,je3
5148  DO i=is,ie+1
5149  bl(i, j) = al(i, j) - v(i, j)
5150  br(i, j) = al(i, j+1) - v(i, j)
5151  END DO
5152  END DO
5153  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
5154  IF (js .EQ. 1) THEN
5155  DO i=is,ie+1
5156  bl(i, 0) = c1*v(i, -2) + c2*v(i, -1) + c3*v(i, 0) - v(i, 0)
5157  xt = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
5158 & )/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(&
5159 & i, 1)*v(i, 2))/(dy(i, 1)+dy(i, 2)))
5160  br(i, 0) = xt - v(i, 0)
5161  bl(i, 1) = xt - v(i, 1)
5162  xt = c3*v(i, 1) + c2*v(i, 2) + c1*v(i, 3)
5163  br(i, 1) = xt - v(i, 1)
5164  bl(i, 2) = xt - v(i, 2)
5165  br(i, 2) = al(i, 3) - v(i, 2)
5166  END DO
5167  IF (is .EQ. 1) THEN
5168 ! out
5169  bl(1, 0) = 0.
5170 ! edge
5171  br(1, 0) = 0.
5172 ! edge
5173  bl(1, 1) = 0.
5174 ! in
5175  br(1, 1) = 0.
5176  END IF
5177  IF (ie + 1 .EQ. npx) THEN
5178 ! out
5179  bl(npx, 0) = 0.
5180 ! edge
5181  br(npx, 0) = 0.
5182 ! edge
5183  bl(npx, 1) = 0.
5184 ! in
5185  br(npx, 1) = 0.
5186  END IF
5187  END IF
5188 ! j=2
5189 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
5190  IF (je + 1 .EQ. npy) THEN
5191  DO i=is,ie+1
5192  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
5193  xt = c1*v(i, npy-3) + c2*v(i, npy-2) + c3*v(i, npy-1)
5194  br(i, npy-2) = xt - v(i, npy-2)
5195  bl(i, npy-1) = xt - v(i, npy-1)
5196  xt = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
5197 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+((2.*dy(i&
5198 & , npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)*v(i, npy+1))/(dy&
5199 & (i, npy)+dy(i, npy+1)))
5200  br(i, npy-1) = xt - v(i, npy-1)
5201  bl(i, npy) = xt - v(i, npy)
5202  br(i, npy) = c3*v(i, npy) + c2*v(i, npy+1) + c1*v(i, npy+2) &
5203 & - v(i, npy)
5204  END DO
5205  IF (is .EQ. 1) THEN
5206 ! in
5207  bl(1, npy-1) = 0.
5208 ! edge
5209  br(1, npy-1) = 0.
5210 ! edge
5211  bl(1, npy) = 0.
5212 ! out
5213  br(1, npy) = 0.
5214  END IF
5215  IF (ie + 1 .EQ. npx) THEN
5216 ! in
5217  bl(npx, npy-1) = 0.
5218 ! edge
5219  br(npx, npy-1) = 0.
5220 ! edge
5221  bl(npx, npy) = 0.
5222 ! out
5223  br(npx, npy) = 0.
5224  END IF
5225  END IF
5226  END IF
5227 ! j=npy-2
5228 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
5229  DO j=js-1,je+1
5230  DO i=is,ie+1
5231  b0(i, j) = bl(i, j) + br(i, j)
5232  END DO
5233  END DO
5234  IF (jord .EQ. 2) THEN
5235 ! Perfectly linear
5236  DO j=js,je+1
5237 !DEC$ VECTOR ALWAYS
5238  DO i=is,ie+1
5239  IF (c(i, j) .GT. 0.) THEN
5240  cfl = c(i, j)*rdy(i, j-1)
5241  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-&
5242 & 1))
5243  ELSE
5244  cfl = c(i, j)*rdy(i, j)
5245  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
5246  END IF
5247  END DO
5248  END DO
5249  ELSE IF (jord .EQ. 3) THEN
5250  DO j=js-1,je+1
5251  DO i=is,ie+1
5252  IF (b0(i, j) .GE. 0.) THEN
5253  x0 = b0(i, j)
5254  ELSE
5255  x0 = -b0(i, j)
5256  END IF
5257  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5258  x1 = bl(i, j) - br(i, j)
5259  ELSE
5260  x1 = -(bl(i, j)-br(i, j))
5261  END IF
5262  smt5(i, j) = x0 .LT. x1
5263  smt6(i, j) = 3.*x0 .LT. x1
5264  END DO
5265  END DO
5266  DO j=js,je+1
5267  DO i=is,ie+1
5268  fx0(i) = 0.
5269  END DO
5270  DO i=is,ie+1
5271  IF (c(i, j) .GT. 0.) THEN
5272  cfl = c(i, j)*rdy(i, j-1)
5273  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
5274  fx0(i) = br(i, j-1) - cfl*b0(i, j-1)
5275  ELSE IF (smt5(i, j-1)) THEN
5276  IF (bl(i, j-1) .GE. 0.) THEN
5277  x2 = bl(i, j-1)
5278  ELSE
5279  x2 = -bl(i, j-1)
5280  END IF
5281  IF (br(i, j-1) .GE. 0.) THEN
5282  y1 = br(i, j-1)
5283  ELSE
5284  y1 = -br(i, j-1)
5285  END IF
5286  IF (x2 .GT. y1) THEN
5287  min1 = y1
5288  ELSE
5289  min1 = x2
5290  END IF
5291 ! piece-wise linear
5292  fx0(i) = sign(min1, br(i, j-1))
5293  END IF
5294  flux(i, j) = v(i, j-1) + (1.-cfl)*fx0(i)
5295  ELSE
5296  cfl = c(i, j)*rdy(i, j)
5297  IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
5298  fx0(i) = bl(i, j) + cfl*b0(i, j)
5299  ELSE IF (smt5(i, j)) THEN
5300  IF (bl(i, j) .GE. 0.) THEN
5301  x3 = bl(i, j)
5302  ELSE
5303  x3 = -bl(i, j)
5304  END IF
5305  IF (br(i, j) .GE. 0.) THEN
5306  y2 = br(i, j)
5307  ELSE
5308  y2 = -br(i, j)
5309  END IF
5310  IF (x3 .GT. y2) THEN
5311  min2 = y2
5312  ELSE
5313  min2 = x3
5314  END IF
5315  fx0(i) = sign(min2, bl(i, j))
5316  END IF
5317  flux(i, j) = v(i, j) + (1.+cfl)*fx0(i)
5318  END IF
5319  END DO
5320  END DO
5321  ELSE IF (jord .EQ. 4) THEN
5322  DO j=js-1,je+1
5323  DO i=is,ie+1
5324  IF (b0(i, j) .GE. 0.) THEN
5325  x0 = b0(i, j)
5326  ELSE
5327  x0 = -b0(i, j)
5328  END IF
5329  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5330  x1 = bl(i, j) - br(i, j)
5331  ELSE
5332  x1 = -(bl(i, j)-br(i, j))
5333  END IF
5334  smt5(i, j) = x0 .LT. x1
5335  smt6(i, j) = 3.*x0 .LT. x1
5336  END DO
5337  END DO
5338  DO j=js,je+1
5339  DO i=is,ie+1
5340  IF (c(i, j) .GT. 0.) THEN
5341  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
5342  cfl = c(i, j)*rdy(i, j-1)
5343  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, &
5344 & j-1))
5345  ELSE
5346  flux(i, j) = v(i, j-1)
5347  END IF
5348  ELSE IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
5349  cfl = c(i, j)*rdy(i, j)
5350  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
5351  ELSE
5352  flux(i, j) = v(i, j)
5353  END IF
5354  END DO
5355  END DO
5356  ELSE
5357 ! jord = 5,6,7
5358 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
5359  IF (jord .EQ. 5) THEN
5360  DO j=js-1,je+1
5361  DO i=is,ie+1
5362  smt5(i, j) = bl(i, j)*br(i, j) .LT. 0.
5363  END DO
5364  END DO
5365  ELSE
5366 ! ord = 6, 7
5367  DO j=js-1,je+1
5368  DO i=is,ie+1
5369  IF (3.*b0(i, j) .GE. 0.) THEN
5370  abs0 = 3.*b0(i, j)
5371  ELSE
5372  abs0 = -(3.*b0(i, j))
5373  END IF
5374  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5375  abs4 = bl(i, j) - br(i, j)
5376  ELSE
5377  abs4 = -(bl(i, j)-br(i, j))
5378  END IF
5379  smt5(i, j) = abs0 .LT. abs4
5380  END DO
5381  END DO
5382  END IF
5383  DO j=js,je+1
5384 !DEC$ VECTOR ALWAYS
5385  DO i=is,ie+1
5386  IF (c(i, j) .GT. 0.) THEN
5387  cfl = c(i, j)*rdy(i, j-1)
5388  fx0(i) = (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-1))
5389  flux(i, j) = v(i, j-1)
5390  ELSE
5391  cfl = c(i, j)*rdy(i, j)
5392  fx0(i) = (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
5393  flux(i, j) = v(i, j)
5394  END IF
5395  IF (smt5(i, j-1) .OR. smt5(i, j)) flux(i, j) = flux(i, j) + &
5396 & fx0(i)
5397  END DO
5398  END DO
5399  END IF
5400  ELSE
5401 ! jord= 8, 9, 10
5402  DO j=js-2,je+2
5403  DO i=is,ie+1
5404  xt = 0.25*(v(i, j+1)-v(i, j-1))
5405  IF (xt .GE. 0.) THEN
5406  x4 = xt
5407  ELSE
5408  x4 = -xt
5409  END IF
5410  IF (v(i, j-1) .LT. v(i, j)) THEN
5411  IF (v(i, j) .LT. v(i, j+1)) THEN
5412  max1 = v(i, j+1)
5413  ELSE
5414  max1 = v(i, j)
5415  END IF
5416  ELSE IF (v(i, j-1) .LT. v(i, j+1)) THEN
5417  max1 = v(i, j+1)
5418  ELSE
5419  max1 = v(i, j-1)
5420  END IF
5421  y3 = max1 - v(i, j)
5422  IF (v(i, j-1) .GT. v(i, j)) THEN
5423  IF (v(i, j) .GT. v(i, j+1)) THEN
5424  min6 = v(i, j+1)
5425  ELSE
5426  min6 = v(i, j)
5427  END IF
5428  ELSE IF (v(i, j-1) .GT. v(i, j+1)) THEN
5429  min6 = v(i, j+1)
5430  ELSE
5431  min6 = v(i, j-1)
5432  END IF
5433  z1 = v(i, j) - min6
5434  IF (x4 .GT. y3) THEN
5435  IF (y3 .GT. z1) THEN
5436  min3 = z1
5437  ELSE
5438  min3 = y3
5439  END IF
5440  ELSE IF (x4 .GT. z1) THEN
5441  min3 = z1
5442  ELSE
5443  min3 = x4
5444  END IF
5445  dm(i, j) = sign(min3, xt)
5446  END DO
5447  END DO
5448  DO j=js-3,je+2
5449  DO i=is,ie+1
5450  dq(i, j) = v(i, j+1) - v(i, j)
5451  END DO
5452  END DO
5453  IF (grid_type .LT. 3) THEN
5454  DO j=js3,je3+1
5455  DO i=is,ie+1
5456  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
5457 & )
5458  END DO
5459  END DO
5460  IF (jord .EQ. 8) THEN
5461  DO j=js3,je3
5462  DO i=is,ie+1
5463  xt = 2.*dm(i, j)
5464  IF (xt .GE. 0.) THEN
5465  x5 = xt
5466  ELSE
5467  x5 = -xt
5468  END IF
5469  IF (al(i, j) - v(i, j) .GE. 0.) THEN
5470  y4 = al(i, j) - v(i, j)
5471  ELSE
5472  y4 = -(al(i, j)-v(i, j))
5473  END IF
5474  IF (x5 .GT. y4) THEN
5475  min4 = y4
5476  ELSE
5477  min4 = x5
5478  END IF
5479  bl(i, j) = -sign(min4, xt)
5480  IF (xt .GE. 0.) THEN
5481  x6 = xt
5482  ELSE
5483  x6 = -xt
5484  END IF
5485  IF (al(i, j+1) - v(i, j) .GE. 0.) THEN
5486  y5 = al(i, j+1) - v(i, j)
5487  ELSE
5488  y5 = -(al(i, j+1)-v(i, j))
5489  END IF
5490  IF (x6 .GT. y5) THEN
5491  min5 = y5
5492  ELSE
5493  min5 = x6
5494  END IF
5495  br(i, j) = sign(min5, xt)
5496  END DO
5497  END DO
5498  ELSE IF (jord .EQ. 9) THEN
5499  DO j=js3,je3
5500  DO i=is,ie+1
5501  pmp_1 = -(2.*dq(i, j))
5502  lac_1 = pmp_1 + 1.5*dq(i, j+1)
5503  IF (0. .LT. pmp_1) THEN
5504  IF (pmp_1 .LT. lac_1) THEN
5505  x7 = lac_1
5506  ELSE
5507  x7 = pmp_1
5508  END IF
5509  ELSE IF (0. .LT. lac_1) THEN
5510  x7 = lac_1
5511  ELSE
5512  x7 = 0.
5513  END IF
5514  IF (0. .GT. pmp_1) THEN
5515  IF (pmp_1 .GT. lac_1) THEN
5516  y12 = lac_1
5517  ELSE
5518  y12 = pmp_1
5519  END IF
5520  ELSE IF (0. .GT. lac_1) THEN
5521  y12 = lac_1
5522  ELSE
5523  y12 = 0.
5524  END IF
5525  IF (al(i, j) - v(i, j) .LT. y12) THEN
5526  y6 = y12
5527  ELSE
5528  y6 = al(i, j) - v(i, j)
5529  END IF
5530  IF (x7 .GT. y6) THEN
5531  bl(i, j) = y6
5532  ELSE
5533  bl(i, j) = x7
5534  END IF
5535  pmp_2 = 2.*dq(i, j-1)
5536  lac_2 = pmp_2 - 1.5*dq(i, j-2)
5537  IF (0. .LT. pmp_2) THEN
5538  IF (pmp_2 .LT. lac_2) THEN
5539  x8 = lac_2
5540  ELSE
5541  x8 = pmp_2
5542  END IF
5543  ELSE IF (0. .LT. lac_2) THEN
5544  x8 = lac_2
5545  ELSE
5546  x8 = 0.
5547  END IF
5548  IF (0. .GT. pmp_2) THEN
5549  IF (pmp_2 .GT. lac_2) THEN
5550  y13 = lac_2
5551  ELSE
5552  y13 = pmp_2
5553  END IF
5554  ELSE IF (0. .GT. lac_2) THEN
5555  y13 = lac_2
5556  ELSE
5557  y13 = 0.
5558  END IF
5559  IF (al(i, j+1) - v(i, j) .LT. y13) THEN
5560  y7 = y13
5561  ELSE
5562  y7 = al(i, j+1) - v(i, j)
5563  END IF
5564  IF (x8 .GT. y7) THEN
5565  br(i, j) = y7
5566  ELSE
5567  br(i, j) = x8
5568  END IF
5569  END DO
5570  END DO
5571  ELSE IF (jord .EQ. 10) THEN
5572  DO j=js3,je3
5573  DO i=is,ie+1
5574  bl(i, j) = al(i, j) - v(i, j)
5575  br(i, j) = al(i, j+1) - v(i, j)
5576  IF (dm(i, j) .GE. 0.) THEN
5577  abs1 = dm(i, j)
5578  ELSE
5579  abs1 = -dm(i, j)
5580  END IF
5581 ! if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then
5582  IF (abs1 .LT. near_zero) THEN
5583  IF (dm(i, j-1) .GE. 0.) THEN
5584  abs2 = dm(i, j-1)
5585  ELSE
5586  abs2 = -dm(i, j-1)
5587  END IF
5588  IF (dm(i, j+1) .GE. 0.) THEN
5589  abs5 = dm(i, j+1)
5590  ELSE
5591  abs5 = -dm(i, j+1)
5592  END IF
5593  IF (abs2 + abs5 .LT. near_zero) THEN
5594  bl(i, j) = 0.
5595  br(i, j) = 0.
5596  END IF
5597  ELSE
5598  IF (3.*(bl(i, j)+br(i, j)) .GE. 0.) THEN
5599  abs3 = 3.*(bl(i, j)+br(i, j))
5600  ELSE
5601  abs3 = -(3.*(bl(i, j)+br(i, j)))
5602  END IF
5603  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5604  abs6 = bl(i, j) - br(i, j)
5605  ELSE
5606  abs6 = -(bl(i, j)-br(i, j))
5607  END IF
5608  IF (abs3 .GT. abs6) THEN
5609  pmp_1 = -(2.*dq(i, j))
5610  lac_1 = pmp_1 + 1.5*dq(i, j+1)
5611  IF (0. .LT. pmp_1) THEN
5612  IF (pmp_1 .LT. lac_1) THEN
5613  x9 = lac_1
5614  ELSE
5615  x9 = pmp_1
5616  END IF
5617  ELSE IF (0. .LT. lac_1) THEN
5618  x9 = lac_1
5619  ELSE
5620  x9 = 0.
5621  END IF
5622  IF (0. .GT. pmp_1) THEN
5623  IF (pmp_1 .GT. lac_1) THEN
5624  y14 = lac_1
5625  ELSE
5626  y14 = pmp_1
5627  END IF
5628  ELSE IF (0. .GT. lac_1) THEN
5629  y14 = lac_1
5630  ELSE
5631  y14 = 0.
5632  END IF
5633  IF (bl(i, j) .LT. y14) THEN
5634  y8 = y14
5635  ELSE
5636  y8 = bl(i, j)
5637  END IF
5638  IF (x9 .GT. y8) THEN
5639  bl(i, j) = y8
5640  ELSE
5641  bl(i, j) = x9
5642  END IF
5643  pmp_2 = 2.*dq(i, j-1)
5644  lac_2 = pmp_2 - 1.5*dq(i, j-2)
5645  IF (0. .LT. pmp_2) THEN
5646  IF (pmp_2 .LT. lac_2) THEN
5647  x10 = lac_2
5648  ELSE
5649  x10 = pmp_2
5650  END IF
5651  ELSE IF (0. .LT. lac_2) THEN
5652  x10 = lac_2
5653  ELSE
5654  x10 = 0.
5655  END IF
5656  IF (0. .GT. pmp_2) THEN
5657  IF (pmp_2 .GT. lac_2) THEN
5658  y15 = lac_2
5659  ELSE
5660  y15 = pmp_2
5661  END IF
5662  ELSE IF (0. .GT. lac_2) THEN
5663  y15 = lac_2
5664  ELSE
5665  y15 = 0.
5666  END IF
5667  IF (br(i, j) .LT. y15) THEN
5668  y9 = y15
5669  ELSE
5670  y9 = br(i, j)
5671  END IF
5672  IF (x10 .GT. y9) THEN
5673  br(i, j) = y9
5674  ELSE
5675  br(i, j) = x10
5676  END IF
5677  END IF
5678  END IF
5679  END DO
5680  END DO
5681  ELSE
5682 ! Unlimited:
5683  DO j=js3,je3
5684  DO i=is,ie+1
5685  bl(i, j) = al(i, j) - v(i, j)
5686  br(i, j) = al(i, j+1) - v(i, j)
5687  END DO
5688  END DO
5689  END IF
5690 !--------------
5691 ! fix the edges
5692 !--------------
5693  IF (js .EQ. 1 .AND. (.NOT.nested)) THEN
5694  DO i=is,ie+1
5695  br(i, 2) = al(i, 3) - v(i, 2)
5696  xt = s15*v(i, 1) + s11*v(i, 2) - s14*dm(i, 2)
5697  br(i, 1) = xt - v(i, 1)
5698  bl(i, 2) = xt - v(i, 2)
5699  bl(i, 0) = s14*dm(i, -1) - s11*dq(i, -1)
5700  x0l = 0.5*((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
5701 & )/(dy(i, 0)+dy(i, -1))
5702  x0r = 0.5*((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(i, 1)*v(i, 2))/&
5703 & (dy(i, 1)+dy(i, 2))
5704  xt = x0l + x0r
5705  bl(i, 1) = xt - v(i, 1)
5706  br(i, 0) = xt - v(i, 0)
5707  END DO
5708  IF (is .EQ. 1) THEN
5709 ! out
5710  bl(1, 0) = 0.
5711 ! edge
5712  br(1, 0) = 0.
5713 ! edge
5714  bl(1, 1) = 0.
5715 ! in
5716  br(1, 1) = 0.
5717  END IF
5718  IF (ie + 1 .EQ. npx) THEN
5719 ! out
5720  bl(npx, 0) = 0.
5721 ! edge
5722  br(npx, 0) = 0.
5723 ! edge
5724  bl(npx, 1) = 0.
5725 ! in
5726  br(npx, 1) = 0.
5727  END IF
5728  j = 2
5729  CALL pert_ppm(ie - is + 2, v(is:ie+1, j), bl(is:ie+1, j), br(&
5730 & is:ie+1, j), -1)
5731  END IF
5732  IF (je + 1 .EQ. npy .AND. (.NOT.nested)) THEN
5733  DO i=is,ie+1
5734  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
5735  xt = s15*v(i, npy-1) + s11*v(i, npy-2) + s14*dm(i, npy-2)
5736  br(i, npy-2) = xt - v(i, npy-2)
5737  bl(i, npy-1) = xt - v(i, npy-1)
5738  br(i, npy) = s11*dq(i, npy) - s14*dm(i, npy+1)
5739  x0l = 0.5*((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
5740 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))
5741  x0r = 0.5*((2.*dy(i, npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)&
5742 & *v(i, npy+1))/(dy(i, npy)+dy(i, npy+1))
5743  xt = x0l + x0r
5744  br(i, npy-1) = xt - v(i, npy-1)
5745  bl(i, npy) = xt - v(i, npy)
5746  END DO
5747  IF (is .EQ. 1) THEN
5748 ! in
5749  bl(1, npy-1) = 0.
5750 ! edge
5751  br(1, npy-1) = 0.
5752 ! edge
5753  bl(1, npy) = 0.
5754 ! out
5755  br(1, npy) = 0.
5756  END IF
5757  IF (ie + 1 .EQ. npx) THEN
5758 ! in
5759  bl(npx, npy-1) = 0.
5760 ! edge
5761  br(npx, npy-1) = 0.
5762 ! edge
5763  bl(npx, npy) = 0.
5764 ! out
5765  br(npx, npy) = 0.
5766  END IF
5767  j = npy - 2
5768  CALL pert_ppm(ie - is + 2, v(is:ie+1, j), bl(is:ie+1, j), br(&
5769 & is:ie+1, j), -1)
5770  END IF
5771  ELSE
5772  DO j=js-1,je+2
5773  DO i=is,ie+1
5774  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
5775 & )
5776  END DO
5777  END DO
5778  DO j=js-1,je+1
5779  DO i=is,ie+1
5780  pmp = 2.*dq(i, j-1)
5781  lac = pmp - 1.5*dq(i, j-2)
5782  IF (0. .LT. pmp) THEN
5783  IF (pmp .LT. lac) THEN
5784  x11 = lac
5785  ELSE
5786  x11 = pmp
5787  END IF
5788  ELSE IF (0. .LT. lac) THEN
5789  x11 = lac
5790  ELSE
5791  x11 = 0.
5792  END IF
5793  IF (0. .GT. pmp) THEN
5794  IF (pmp .GT. lac) THEN
5795  y16 = lac
5796  ELSE
5797  y16 = pmp
5798  END IF
5799  ELSE IF (0. .GT. lac) THEN
5800  y16 = lac
5801  ELSE
5802  y16 = 0.
5803  END IF
5804  IF (al(i, j+1) - v(i, j) .LT. y16) THEN
5805  y10 = y16
5806  ELSE
5807  y10 = al(i, j+1) - v(i, j)
5808  END IF
5809  IF (x11 .GT. y10) THEN
5810  br(i, j) = y10
5811  ELSE
5812  br(i, j) = x11
5813  END IF
5814  pmp = -(2.*dq(i, j))
5815  lac = pmp + 1.5*dq(i, j+1)
5816  IF (0. .LT. pmp) THEN
5817  IF (pmp .LT. lac) THEN
5818  x12 = lac
5819  ELSE
5820  x12 = pmp
5821  END IF
5822  ELSE IF (0. .LT. lac) THEN
5823  x12 = lac
5824  ELSE
5825  x12 = 0.
5826  END IF
5827  IF (0. .GT. pmp) THEN
5828  IF (pmp .GT. lac) THEN
5829  y17 = lac
5830  ELSE
5831  y17 = pmp
5832  END IF
5833  ELSE IF (0. .GT. lac) THEN
5834  y17 = lac
5835  ELSE
5836  y17 = 0.
5837  END IF
5838  IF (al(i, j) - v(i, j) .LT. y17) THEN
5839  y11 = y17
5840  ELSE
5841  y11 = al(i, j) - v(i, j)
5842  END IF
5843  IF (x12 .GT. y11) THEN
5844  bl(i, j) = y11
5845  ELSE
5846  bl(i, j) = x12
5847  END IF
5848  END DO
5849  END DO
5850  END IF
5851  DO j=js,je+1
5852  DO i=is,ie+1
5853  IF (c(i, j) .GT. 0.) THEN
5854  cfl = c(i, j)*rdy(i, j-1)
5855  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*(bl(i, j-1&
5856 & )+br(i, j-1)))
5857  ELSE
5858  cfl = c(i, j)*rdy(i, j)
5859  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*(bl(i, j)+br(i&
5860 & , j)))
5861  END IF
5862  END DO
5863  END DO
5864  END IF
5865  END SUBROUTINE ytp_v
5866 ! Differentiation of d2a2c_vect in forward (tangent) mode:
5867 ! variations of useful results: ua uc ut va vc vt
5868 ! with respect to varying inputs: u v ua uc ut va vc vt
5869 !There is a limit to how far this routine can fill uc and vc in the
5870 ! halo, and so either mpp_update_domains or some sort of boundary
5871 ! routine (extrapolation, outflow, interpolation from a nested grid)
5872 ! is needed after c_sw is completed if these variables are needed
5873 ! in the halo
5874  SUBROUTINE d2a2c_vect_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, va_tl, uc, &
5875 & uc_tl, vc, vc_tl, ut, ut_tl, vt, vt_tl, dord4, gridstruct, bd, npx, &
5876 & npy, nested, grid_type)
5877  IMPLICIT NONE
5878  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
5879  LOGICAL, INTENT(IN) :: dord4
5880  REAL, INTENT(IN) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5881  REAL, INTENT(IN) :: u_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5882  REAL, INTENT(IN) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5883  REAL, INTENT(IN) :: v_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5884  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(OUT) :: uc
5885  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(OUT) :: &
5886 & uc_tl
5887  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(OUT) :: vc
5888  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(OUT) :: &
5889 & vc_tl
5890  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: ua, va&
5891 & , ut, vt
5892  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: ua_tl&
5893 & , va_tl, ut_tl, vt_tl
5894  INTEGER, INTENT(IN) :: npx, npy, grid_type
5895  LOGICAL, INTENT(IN) :: nested
5896  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
5897 ! Local
5898  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp, vtmp
5899  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp_tl, vtmp_tl
5900  INTEGER :: npt, i, j, ifirst, ilast, id
5901  INTEGER :: is, ie, js, je
5902  INTEGER :: isd, ied, jsd, jed
5903  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
5904  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
5905  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsin2
5906  REAL, DIMENSION(:, :), POINTER :: dxa, dya
5907  INTRINSIC max
5908  INTRINSIC min
5909  INTEGER :: max1
5910  INTEGER :: max2
5911  INTEGER :: max3
5912  INTEGER :: max4
5913  INTEGER :: max5
5914  INTEGER :: max6
5915  INTEGER :: min1
5916  INTEGER :: min2
5917  INTEGER :: min3
5918  INTEGER :: min4
5919  INTEGER :: min5
5920  INTEGER :: min6
5921  is = bd%is
5922  ie = bd%ie
5923  js = bd%js
5924  je = bd%je
5925  isd = bd%isd
5926  ied = bd%ied
5927  jsd = bd%jsd
5928  jed = bd%jed
5929  sin_sg => gridstruct%sin_sg
5930  cosa_u => gridstruct%cosa_u
5931  cosa_v => gridstruct%cosa_v
5932  cosa_s => gridstruct%cosa_s
5933  rsin_u => gridstruct%rsin_u
5934  rsin_v => gridstruct%rsin_v
5935  rsin2 => gridstruct%rsin2
5936  dxa => gridstruct%dxa
5937  dya => gridstruct%dya
5938  IF (dord4) THEN
5939  id = 1
5940  ELSE
5941  id = 0
5942  END IF
5943  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
5944  npt = 4
5945  ELSE
5946  npt = -2
5947  END IF
5948 ! Initialize the non-existing corner regions
5949  utmp(:, :) = big_number
5950  vtmp(:, :) = big_number
5951  IF (nested) THEN
5952  utmp_tl = 0.0
5953  DO j=jsd+1,jed-1
5954  DO i=isd,ied
5955  utmp_tl(i, j) = a2*(u_tl(i, j-1)+u_tl(i, j+2)) + a1*(u_tl(i, j&
5956 & )+u_tl(i, j+1))
5957  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
5958  END DO
5959  END DO
5960  DO i=isd,ied
5961 !j = jsd
5962  utmp_tl(i, jsd) = 0.5*(u_tl(i, jsd)+u_tl(i, jsd+1))
5963  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
5964 !j = jed
5965  utmp_tl(i, jed) = 0.5*(u_tl(i, jed)+u_tl(i, jed+1))
5966  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
5967  END DO
5968  vtmp_tl = 0.0
5969  DO j=jsd,jed
5970  DO i=isd+1,ied-1
5971  vtmp_tl(i, j) = a2*(v_tl(i-1, j)+v_tl(i+2, j)) + a1*(v_tl(i, j&
5972 & )+v_tl(i+1, j))
5973  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
5974  END DO
5975 !i = isd
5976  vtmp_tl(isd, j) = 0.5*(v_tl(isd, j)+v_tl(isd+1, j))
5977  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
5978 !i = ied
5979  vtmp_tl(ied, j) = 0.5*(v_tl(ied, j)+v_tl(ied+1, j))
5980  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
5981  END DO
5982  DO j=jsd,jed
5983  DO i=isd,ied
5984  ua_tl(i, j) = rsin2(i, j)*(utmp_tl(i, j)-cosa_s(i, j)*vtmp_tl(&
5985 & i, j))
5986  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
5987  va_tl(i, j) = rsin2(i, j)*(vtmp_tl(i, j)-cosa_s(i, j)*utmp_tl(&
5988 & i, j))
5989  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
5990  END DO
5991  END DO
5992  ELSE
5993  IF (npt .LT. js - 1) THEN
5994  max1 = js - 1
5995  ELSE
5996  max1 = npt
5997  END IF
5998  IF (npy - npt .GT. je + 1) THEN
5999  min1 = je + 1
6000  utmp_tl = 0.0
6001  ELSE
6002  min1 = npy - npt
6003  utmp_tl = 0.0
6004  END IF
6005 !----------
6006 ! Interior:
6007 !----------
6008  DO j=max1,min1
6009  IF (npt .LT. isd) THEN
6010  max2 = isd
6011  ELSE
6012  max2 = npt
6013  END IF
6014  IF (npx - npt .GT. ied) THEN
6015  min2 = ied
6016  ELSE
6017  min2 = npx - npt
6018  END IF
6019  DO i=max2,min2
6020  utmp_tl(i, j) = a2*(u_tl(i, j-1)+u_tl(i, j+2)) + a1*(u_tl(i, j&
6021 & )+u_tl(i, j+1))
6022  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
6023  END DO
6024  END DO
6025  IF (npt .LT. jsd) THEN
6026  max3 = jsd
6027  ELSE
6028  max3 = npt
6029  END IF
6030  IF (npy - npt .GT. jed) THEN
6031  min3 = jed
6032  vtmp_tl = 0.0
6033  ELSE
6034  min3 = npy - npt
6035  vtmp_tl = 0.0
6036  END IF
6037  DO j=max3,min3
6038  IF (npt .LT. is - 1) THEN
6039  max4 = is - 1
6040  ELSE
6041  max4 = npt
6042  END IF
6043  IF (npx - npt .GT. ie + 1) THEN
6044  min4 = ie + 1
6045  ELSE
6046  min4 = npx - npt
6047  END IF
6048  DO i=max4,min4
6049  vtmp_tl(i, j) = a2*(v_tl(i-1, j)+v_tl(i+2, j)) + a1*(v_tl(i, j&
6050 & )+v_tl(i+1, j))
6051  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
6052  END DO
6053  END DO
6054 !----------
6055 ! edges:
6056 !----------
6057  IF (grid_type .LT. 3) THEN
6058  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
6059  DO j=jsd,npt-1
6060  DO i=isd,ied
6061  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
6062  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6063  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
6064  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6065  END DO
6066  END DO
6067  END IF
6068  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
6069  DO j=npy-npt+1,jed
6070  DO i=isd,ied
6071  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
6072  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6073  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
6074  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6075  END DO
6076  END DO
6077  END IF
6078  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
6079  IF (npt .LT. jsd) THEN
6080  max5 = jsd
6081  ELSE
6082  max5 = npt
6083  END IF
6084  IF (npy - npt .GT. jed) THEN
6085  min5 = jed
6086  ELSE
6087  min5 = npy - npt
6088  END IF
6089  DO j=max5,min5
6090  DO i=isd,npt-1
6091  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
6092  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6093  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
6094  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6095  END DO
6096  END DO
6097  END IF
6098  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
6099  IF (npt .LT. jsd) THEN
6100  max6 = jsd
6101  ELSE
6102  max6 = npt
6103  END IF
6104  IF (npy - npt .GT. jed) THEN
6105  min6 = jed
6106  ELSE
6107  min6 = npy - npt
6108  END IF
6109  DO j=max6,min6
6110  DO i=npx-npt+1,ied
6111  utmp_tl(i, j) = 0.5*(u_tl(i, j)+u_tl(i, j+1))
6112  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6113  vtmp_tl(i, j) = 0.5*(v_tl(i, j)+v_tl(i+1, j))
6114  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6115  END DO
6116  END DO
6117  END IF
6118  END IF
6119 ! Contra-variant components at cell center:
6120  DO j=js-1-id,je+1+id
6121  DO i=is-1-id,ie+1+id
6122  ua_tl(i, j) = rsin2(i, j)*(utmp_tl(i, j)-cosa_s(i, j)*vtmp_tl(&
6123 & i, j))
6124  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6125  va_tl(i, j) = rsin2(i, j)*(vtmp_tl(i, j)-cosa_s(i, j)*utmp_tl(&
6126 & i, j))
6127  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6128  END DO
6129  END DO
6130  END IF
6131 ! A -> C
6132 !--------------
6133 ! Fix the edges
6134 !--------------
6135 ! Xdir:
6136  IF (gridstruct%sw_corner) THEN
6137  DO i=-2,0
6138  utmp_tl(i, 0) = -vtmp_tl(0, 1-i)
6139  utmp(i, 0) = -vtmp(0, 1-i)
6140  END DO
6141  END IF
6142  IF (gridstruct%se_corner) THEN
6143  DO i=0,2
6144  utmp_tl(npx+i, 0) = vtmp_tl(npx, i+1)
6145  utmp(npx+i, 0) = vtmp(npx, i+1)
6146  END DO
6147  END IF
6148  IF (gridstruct%ne_corner) THEN
6149  DO i=0,2
6150  utmp_tl(npx+i, npy) = -vtmp_tl(npx, je-i)
6151  utmp(npx+i, npy) = -vtmp(npx, je-i)
6152  END DO
6153  END IF
6154  IF (gridstruct%nw_corner) THEN
6155  DO i=-2,0
6156  utmp_tl(i, npy) = vtmp_tl(0, je+i)
6157  utmp(i, npy) = vtmp(0, je+i)
6158  END DO
6159  END IF
6160  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
6161  IF (3 .LT. is - 1) THEN
6162  ifirst = is - 1
6163  ELSE
6164  ifirst = 3
6165  END IF
6166  IF (npx - 2 .GT. ie + 2) THEN
6167  ilast = ie + 2
6168  ELSE
6169  ilast = npx - 2
6170  END IF
6171  ELSE
6172  ifirst = is - 1
6173  ilast = ie + 2
6174  END IF
6175 !---------------------------------------------
6176 ! 4th order interpolation for interior points:
6177 !---------------------------------------------
6178  DO j=js-1,je+1
6179  DO i=ifirst,ilast
6180  uc_tl(i, j) = a2*(utmp_tl(i-2, j)+utmp_tl(i+1, j)) + a1*(utmp_tl&
6181 & (i-1, j)+utmp_tl(i, j))
6182  uc(i, j) = a2*(utmp(i-2, j)+utmp(i+1, j)) + a1*(utmp(i-1, j)+&
6183 & utmp(i, j))
6184  ut_tl(i, j) = rsin_u(i, j)*(uc_tl(i, j)-cosa_u(i, j)*v_tl(i, j))
6185  ut(i, j) = (uc(i, j)-v(i, j)*cosa_u(i, j))*rsin_u(i, j)
6186  END DO
6187  END DO
6188  IF (grid_type .LT. 3) THEN
6189 ! Xdir:
6190  IF (gridstruct%sw_corner) THEN
6191  ua_tl(-1, 0) = -va_tl(0, 2)
6192  ua(-1, 0) = -va(0, 2)
6193  ua_tl(0, 0) = -va_tl(0, 1)
6194  ua(0, 0) = -va(0, 1)
6195  END IF
6196  IF (gridstruct%se_corner) THEN
6197  ua_tl(npx, 0) = va_tl(npx, 1)
6198  ua(npx, 0) = va(npx, 1)
6199  ua_tl(npx+1, 0) = va_tl(npx, 2)
6200  ua(npx+1, 0) = va(npx, 2)
6201  END IF
6202  IF (gridstruct%ne_corner) THEN
6203  ua_tl(npx, npy) = -va_tl(npx, npy-1)
6204  ua(npx, npy) = -va(npx, npy-1)
6205  ua_tl(npx+1, npy) = -va_tl(npx, npy-2)
6206  ua(npx+1, npy) = -va(npx, npy-2)
6207  END IF
6208  IF (gridstruct%nw_corner) THEN
6209  ua_tl(-1, npy) = va_tl(0, npy-2)
6210  ua(-1, npy) = va(0, npy-2)
6211  ua_tl(0, npy) = va_tl(0, npy-1)
6212  ua(0, npy) = va(0, npy-1)
6213  END IF
6214  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
6215  DO j=js-1,je+1
6216  uc_tl(0, j) = c1*utmp_tl(-2, j) + c2*utmp_tl(-1, j) + c3*&
6217 & utmp_tl(0, j)
6218  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
6219  ut_tl(1, j) = edge_interpolate4_tlm(ua(-1:2, j), ua_tl(-1:2, j&
6220 & ), dxa(-1:2, j), ut(1, j))
6221 !Want to use the UPSTREAM value
6222  IF (ut(1, j) .GT. 0.) THEN
6223  uc_tl(1, j) = sin_sg(0, j, 3)*ut_tl(1, j)
6224  uc(1, j) = ut(1, j)*sin_sg(0, j, 3)
6225  ELSE
6226  uc_tl(1, j) = sin_sg(1, j, 1)*ut_tl(1, j)
6227  uc(1, j) = ut(1, j)*sin_sg(1, j, 1)
6228  END IF
6229  uc_tl(2, j) = c1*utmp_tl(3, j) + c2*utmp_tl(2, j) + c3*utmp_tl&
6230 & (1, j)
6231  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
6232  ut_tl(0, j) = rsin_u(0, j)*(uc_tl(0, j)-cosa_u(0, j)*v_tl(0, j&
6233 & ))
6234  ut(0, j) = (uc(0, j)-v(0, j)*cosa_u(0, j))*rsin_u(0, j)
6235  ut_tl(2, j) = rsin_u(2, j)*(uc_tl(2, j)-cosa_u(2, j)*v_tl(2, j&
6236 & ))
6237  ut(2, j) = (uc(2, j)-v(2, j)*cosa_u(2, j))*rsin_u(2, j)
6238  END DO
6239  END IF
6240  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
6241  DO j=js-1,je+1
6242  uc_tl(npx-1, j) = c1*utmp_tl(npx-3, j) + c2*utmp_tl(npx-2, j) &
6243 & + c3*utmp_tl(npx-1, j)
6244  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
6245 & (npx-1, j)
6246  ut_tl(npx, j) = edge_interpolate4_tlm(ua(npx-2:npx+1, j), &
6247 & ua_tl(npx-2:npx+1, j), dxa(npx-2:npx+1, j), ut(npx, j))
6248  IF (ut(npx, j) .GT. 0.) THEN
6249  uc_tl(npx, j) = sin_sg(npx-1, j, 3)*ut_tl(npx, j)
6250  uc(npx, j) = ut(npx, j)*sin_sg(npx-1, j, 3)
6251  ELSE
6252  uc_tl(npx, j) = sin_sg(npx, j, 1)*ut_tl(npx, j)
6253  uc(npx, j) = ut(npx, j)*sin_sg(npx, j, 1)
6254  END IF
6255  uc_tl(npx+1, j) = c3*utmp_tl(npx, j) + c2*utmp_tl(npx+1, j) + &
6256 & c1*utmp_tl(npx+2, j)
6257  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
6258 & npx+2, j)
6259  ut_tl(npx-1, j) = rsin_u(npx-1, j)*(uc_tl(npx-1, j)-cosa_u(npx&
6260 & -1, j)*v_tl(npx-1, j))
6261  ut(npx-1, j) = (uc(npx-1, j)-v(npx-1, j)*cosa_u(npx-1, j))*&
6262 & rsin_u(npx-1, j)
6263  ut_tl(npx+1, j) = rsin_u(npx+1, j)*(uc_tl(npx+1, j)-cosa_u(npx&
6264 & +1, j)*v_tl(npx+1, j))
6265  ut(npx+1, j) = (uc(npx+1, j)-v(npx+1, j)*cosa_u(npx+1, j))*&
6266 & rsin_u(npx+1, j)
6267  END DO
6268  END IF
6269  END IF
6270 !------
6271 ! Ydir:
6272 !------
6273  IF (gridstruct%sw_corner) THEN
6274  DO j=-2,0
6275  vtmp_tl(0, j) = -utmp_tl(1-j, 0)
6276  vtmp(0, j) = -utmp(1-j, 0)
6277  END DO
6278  END IF
6279  IF (gridstruct%nw_corner) THEN
6280  DO j=0,2
6281  vtmp_tl(0, npy+j) = utmp_tl(j+1, npy)
6282  vtmp(0, npy+j) = utmp(j+1, npy)
6283  END DO
6284  END IF
6285  IF (gridstruct%se_corner) THEN
6286  DO j=-2,0
6287  vtmp_tl(npx, j) = utmp_tl(ie+j, 0)
6288  vtmp(npx, j) = utmp(ie+j, 0)
6289  END DO
6290  END IF
6291  IF (gridstruct%ne_corner) THEN
6292  DO j=0,2
6293  vtmp_tl(npx, npy+j) = -utmp_tl(ie-j, npy)
6294  vtmp(npx, npy+j) = -utmp(ie-j, npy)
6295  END DO
6296  END IF
6297  IF (gridstruct%sw_corner) THEN
6298  va_tl(0, -1) = -ua_tl(2, 0)
6299  va(0, -1) = -ua(2, 0)
6300  va_tl(0, 0) = -ua_tl(1, 0)
6301  va(0, 0) = -ua(1, 0)
6302  END IF
6303  IF (gridstruct%se_corner) THEN
6304  va_tl(npx, 0) = ua_tl(npx-1, 0)
6305  va(npx, 0) = ua(npx-1, 0)
6306  va_tl(npx, -1) = ua_tl(npx-2, 0)
6307  va(npx, -1) = ua(npx-2, 0)
6308  END IF
6309  IF (gridstruct%ne_corner) THEN
6310  va_tl(npx, npy) = -ua_tl(npx-1, npy)
6311  va(npx, npy) = -ua(npx-1, npy)
6312  va_tl(npx, npy+1) = -ua_tl(npx-2, npy)
6313  va(npx, npy+1) = -ua(npx-2, npy)
6314  END IF
6315  IF (gridstruct%nw_corner) THEN
6316  va_tl(0, npy) = ua_tl(1, npy)
6317  va(0, npy) = ua(1, npy)
6318  va_tl(0, npy+1) = ua_tl(2, npy)
6319  va(0, npy+1) = ua(2, npy)
6320  END IF
6321  IF (grid_type .LT. 3) THEN
6322  DO j=js-1,je+2
6323  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
6324  DO i=is-1,ie+1
6325  vt_tl(i, j) = edge_interpolate4_tlm(va(i, -1:2), va_tl(i, -1&
6326 & :2), dya(i, -1:2), vt(i, j))
6327  IF (vt(i, j) .GT. 0.) THEN
6328  vc_tl(i, j) = sin_sg(i, j-1, 4)*vt_tl(i, j)
6329  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
6330  ELSE
6331  vc_tl(i, j) = sin_sg(i, j, 2)*vt_tl(i, j)
6332  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
6333  END IF
6334  END DO
6335  ELSE IF (j .EQ. 0 .OR. (j .EQ. npy - 1 .AND. (.NOT.nested))) &
6336 & THEN
6337  DO i=is-1,ie+1
6338  vc_tl(i, j) = c1*vtmp_tl(i, j-2) + c2*vtmp_tl(i, j-1) + c3*&
6339 & vtmp_tl(i, j)
6340  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
6341  vt_tl(i, j) = rsin_v(i, j)*(vc_tl(i, j)-cosa_v(i, j)*u_tl(i&
6342 & , j))
6343  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6344  END DO
6345  ELSE IF (j .EQ. 2 .OR. (j .EQ. npy + 1 .AND. (.NOT.nested))) &
6346 & THEN
6347  DO i=is-1,ie+1
6348  vc_tl(i, j) = c1*vtmp_tl(i, j+1) + c2*vtmp_tl(i, j) + c3*&
6349 & vtmp_tl(i, j-1)
6350  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
6351  vt_tl(i, j) = rsin_v(i, j)*(vc_tl(i, j)-cosa_v(i, j)*u_tl(i&
6352 & , j))
6353  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6354  END DO
6355  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
6356  DO i=is-1,ie+1
6357  vt_tl(i, j) = edge_interpolate4_tlm(va(i, j-2:j+1), va_tl(i&
6358 & , j-2:j+1), dya(i, j-2:j+1), vt(i, j))
6359  IF (vt(i, j) .GT. 0.) THEN
6360  vc_tl(i, j) = sin_sg(i, j-1, 4)*vt_tl(i, j)
6361  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
6362  ELSE
6363  vc_tl(i, j) = sin_sg(i, j, 2)*vt_tl(i, j)
6364  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
6365  END IF
6366  END DO
6367  ELSE
6368 ! 4th order interpolation for interior points:
6369  DO i=is-1,ie+1
6370  vc_tl(i, j) = a2*(vtmp_tl(i, j-2)+vtmp_tl(i, j+1)) + a1*(&
6371 & vtmp_tl(i, j-1)+vtmp_tl(i, j))
6372  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
6373 & +vtmp(i, j))
6374  vt_tl(i, j) = rsin_v(i, j)*(vc_tl(i, j)-cosa_v(i, j)*u_tl(i&
6375 & , j))
6376  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6377  END DO
6378  END IF
6379  END DO
6380  ELSE
6381 ! 4th order interpolation:
6382  DO j=js-1,je+2
6383  DO i=is-1,ie+1
6384  vc_tl(i, j) = a2*(vtmp_tl(i, j-2)+vtmp_tl(i, j+1)) + a1*(&
6385 & vtmp_tl(i, j-1)+vtmp_tl(i, j))
6386  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
6387 & vtmp(i, j))
6388  vt_tl(i, j) = vc_tl(i, j)
6389  vt(i, j) = vc(i, j)
6390  END DO
6391  END DO
6392  END IF
6393  END SUBROUTINE d2a2c_vect_tlm
6394 !There is a limit to how far this routine can fill uc and vc in the
6395 ! halo, and so either mpp_update_domains or some sort of boundary
6396 ! routine (extrapolation, outflow, interpolation from a nested grid)
6397 ! is needed after c_sw is completed if these variables are needed
6398 ! in the halo
6399  SUBROUTINE d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct&
6400 & , bd, npx, npy, nested, grid_type)
6401  IMPLICIT NONE
6402  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6403  LOGICAL, INTENT(IN) :: dord4
6404  REAL, INTENT(IN) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
6405  REAL, INTENT(IN) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed)
6406  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(OUT) :: uc
6407  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(OUT) :: vc
6408  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: ua, va&
6409 & , ut, vt
6410  INTEGER, INTENT(IN) :: npx, npy, grid_type
6411  LOGICAL, INTENT(IN) :: nested
6412  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6413 ! Local
6414  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp, vtmp
6415  INTEGER :: npt, i, j, ifirst, ilast, id
6416  INTEGER :: is, ie, js, je
6417  INTEGER :: isd, ied, jsd, jed
6418  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
6419  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
6420  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsin2
6421  REAL, DIMENSION(:, :), POINTER :: dxa, dya
6422  INTRINSIC max
6423  INTRINSIC min
6424  INTEGER :: max1
6425  INTEGER :: max2
6426  INTEGER :: max3
6427  INTEGER :: max4
6428  INTEGER :: max5
6429  INTEGER :: max6
6430  INTEGER :: min1
6431  INTEGER :: min2
6432  INTEGER :: min3
6433  INTEGER :: min4
6434  INTEGER :: min5
6435  INTEGER :: min6
6436  is = bd%is
6437  ie = bd%ie
6438  js = bd%js
6439  je = bd%je
6440  isd = bd%isd
6441  ied = bd%ied
6442  jsd = bd%jsd
6443  jed = bd%jed
6444  sin_sg => gridstruct%sin_sg
6445  cosa_u => gridstruct%cosa_u
6446  cosa_v => gridstruct%cosa_v
6447  cosa_s => gridstruct%cosa_s
6448  rsin_u => gridstruct%rsin_u
6449  rsin_v => gridstruct%rsin_v
6450  rsin2 => gridstruct%rsin2
6451  dxa => gridstruct%dxa
6452  dya => gridstruct%dya
6453  IF (dord4) THEN
6454  id = 1
6455  ELSE
6456  id = 0
6457  END IF
6458  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
6459  npt = 4
6460  ELSE
6461  npt = -2
6462  END IF
6463 ! Initialize the non-existing corner regions
6464  utmp(:, :) = big_number
6465  vtmp(:, :) = big_number
6466  IF (nested) THEN
6467  DO j=jsd+1,jed-1
6468  DO i=isd,ied
6469  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
6470  END DO
6471  END DO
6472  DO i=isd,ied
6473 !j = jsd
6474  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
6475 !j = jed
6476  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
6477  END DO
6478  DO j=jsd,jed
6479  DO i=isd+1,ied-1
6480  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
6481  END DO
6482 !i = isd
6483  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
6484 !i = ied
6485  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
6486  END DO
6487  DO j=jsd,jed
6488  DO i=isd,ied
6489  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6490  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6491  END DO
6492  END DO
6493  ELSE
6494  IF (npt .LT. js - 1) THEN
6495  max1 = js - 1
6496  ELSE
6497  max1 = npt
6498  END IF
6499  IF (npy - npt .GT. je + 1) THEN
6500  min1 = je + 1
6501  ELSE
6502  min1 = npy - npt
6503  END IF
6504 !----------
6505 ! Interior:
6506 !----------
6507  DO j=max1,min1
6508  IF (npt .LT. isd) THEN
6509  max2 = isd
6510  ELSE
6511  max2 = npt
6512  END IF
6513  IF (npx - npt .GT. ied) THEN
6514  min2 = ied
6515  ELSE
6516  min2 = npx - npt
6517  END IF
6518  DO i=max2,min2
6519  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
6520  END DO
6521  END DO
6522  IF (npt .LT. jsd) THEN
6523  max3 = jsd
6524  ELSE
6525  max3 = npt
6526  END IF
6527  IF (npy - npt .GT. jed) THEN
6528  min3 = jed
6529  ELSE
6530  min3 = npy - npt
6531  END IF
6532  DO j=max3,min3
6533  IF (npt .LT. is - 1) THEN
6534  max4 = is - 1
6535  ELSE
6536  max4 = npt
6537  END IF
6538  IF (npx - npt .GT. ie + 1) THEN
6539  min4 = ie + 1
6540  ELSE
6541  min4 = npx - npt
6542  END IF
6543  DO i=max4,min4
6544  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
6545  END DO
6546  END DO
6547 !----------
6548 ! edges:
6549 !----------
6550  IF (grid_type .LT. 3) THEN
6551  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
6552  DO j=jsd,npt-1
6553  DO i=isd,ied
6554  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6555  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6556  END DO
6557  END DO
6558  END IF
6559  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
6560  DO j=npy-npt+1,jed
6561  DO i=isd,ied
6562  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6563  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6564  END DO
6565  END DO
6566  END IF
6567  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
6568  IF (npt .LT. jsd) THEN
6569  max5 = jsd
6570  ELSE
6571  max5 = npt
6572  END IF
6573  IF (npy - npt .GT. jed) THEN
6574  min5 = jed
6575  ELSE
6576  min5 = npy - npt
6577  END IF
6578  DO j=max5,min5
6579  DO i=isd,npt-1
6580  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6581  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6582  END DO
6583  END DO
6584  END IF
6585  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
6586  IF (npt .LT. jsd) THEN
6587  max6 = jsd
6588  ELSE
6589  max6 = npt
6590  END IF
6591  IF (npy - npt .GT. jed) THEN
6592  min6 = jed
6593  ELSE
6594  min6 = npy - npt
6595  END IF
6596  DO j=max6,min6
6597  DO i=npx-npt+1,ied
6598  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
6599  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
6600  END DO
6601  END DO
6602  END IF
6603  END IF
6604 ! Contra-variant components at cell center:
6605  DO j=js-1-id,je+1+id
6606  DO i=is-1-id,ie+1+id
6607  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6608  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
6609  END DO
6610  END DO
6611  END IF
6612 ! A -> C
6613 !--------------
6614 ! Fix the edges
6615 !--------------
6616 ! Xdir:
6617  IF (gridstruct%sw_corner) THEN
6618  DO i=-2,0
6619  utmp(i, 0) = -vtmp(0, 1-i)
6620  END DO
6621  END IF
6622  IF (gridstruct%se_corner) THEN
6623  DO i=0,2
6624  utmp(npx+i, 0) = vtmp(npx, i+1)
6625  END DO
6626  END IF
6627  IF (gridstruct%ne_corner) THEN
6628  DO i=0,2
6629  utmp(npx+i, npy) = -vtmp(npx, je-i)
6630  END DO
6631  END IF
6632  IF (gridstruct%nw_corner) THEN
6633  DO i=-2,0
6634  utmp(i, npy) = vtmp(0, je+i)
6635  END DO
6636  END IF
6637  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
6638  IF (3 .LT. is - 1) THEN
6639  ifirst = is - 1
6640  ELSE
6641  ifirst = 3
6642  END IF
6643  IF (npx - 2 .GT. ie + 2) THEN
6644  ilast = ie + 2
6645  ELSE
6646  ilast = npx - 2
6647  END IF
6648  ELSE
6649  ifirst = is - 1
6650  ilast = ie + 2
6651  END IF
6652 !---------------------------------------------
6653 ! 4th order interpolation for interior points:
6654 !---------------------------------------------
6655  DO j=js-1,je+1
6656  DO i=ifirst,ilast
6657  uc(i, j) = a2*(utmp(i-2, j)+utmp(i+1, j)) + a1*(utmp(i-1, j)+&
6658 & utmp(i, j))
6659  ut(i, j) = (uc(i, j)-v(i, j)*cosa_u(i, j))*rsin_u(i, j)
6660  END DO
6661  END DO
6662  IF (grid_type .LT. 3) THEN
6663 ! Xdir:
6664  IF (gridstruct%sw_corner) THEN
6665  ua(-1, 0) = -va(0, 2)
6666  ua(0, 0) = -va(0, 1)
6667  END IF
6668  IF (gridstruct%se_corner) THEN
6669  ua(npx, 0) = va(npx, 1)
6670  ua(npx+1, 0) = va(npx, 2)
6671  END IF
6672  IF (gridstruct%ne_corner) THEN
6673  ua(npx, npy) = -va(npx, npy-1)
6674  ua(npx+1, npy) = -va(npx, npy-2)
6675  END IF
6676  IF (gridstruct%nw_corner) THEN
6677  ua(-1, npy) = va(0, npy-2)
6678  ua(0, npy) = va(0, npy-1)
6679  END IF
6680  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
6681  DO j=js-1,je+1
6682  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
6683  ut(1, j) = edge_interpolate4(ua(-1:2, j), dxa(-1:2, j))
6684 !Want to use the UPSTREAM value
6685  IF (ut(1, j) .GT. 0.) THEN
6686  uc(1, j) = ut(1, j)*sin_sg(0, j, 3)
6687  ELSE
6688  uc(1, j) = ut(1, j)*sin_sg(1, j, 1)
6689  END IF
6690  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
6691  ut(0, j) = (uc(0, j)-v(0, j)*cosa_u(0, j))*rsin_u(0, j)
6692  ut(2, j) = (uc(2, j)-v(2, j)*cosa_u(2, j))*rsin_u(2, j)
6693  END DO
6694  END IF
6695  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
6696  DO j=js-1,je+1
6697  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
6698 & (npx-1, j)
6699  ut(npx, j) = edge_interpolate4(ua(npx-2:npx+1, j), dxa(npx-2:&
6700 & npx+1, j))
6701  IF (ut(npx, j) .GT. 0.) THEN
6702  uc(npx, j) = ut(npx, j)*sin_sg(npx-1, j, 3)
6703  ELSE
6704  uc(npx, j) = ut(npx, j)*sin_sg(npx, j, 1)
6705  END IF
6706  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
6707 & npx+2, j)
6708  ut(npx-1, j) = (uc(npx-1, j)-v(npx-1, j)*cosa_u(npx-1, j))*&
6709 & rsin_u(npx-1, j)
6710  ut(npx+1, j) = (uc(npx+1, j)-v(npx+1, j)*cosa_u(npx+1, j))*&
6711 & rsin_u(npx+1, j)
6712  END DO
6713  END IF
6714  END IF
6715 !------
6716 ! Ydir:
6717 !------
6718  IF (gridstruct%sw_corner) THEN
6719  DO j=-2,0
6720  vtmp(0, j) = -utmp(1-j, 0)
6721  END DO
6722  END IF
6723  IF (gridstruct%nw_corner) THEN
6724  DO j=0,2
6725  vtmp(0, npy+j) = utmp(j+1, npy)
6726  END DO
6727  END IF
6728  IF (gridstruct%se_corner) THEN
6729  DO j=-2,0
6730  vtmp(npx, j) = utmp(ie+j, 0)
6731  END DO
6732  END IF
6733  IF (gridstruct%ne_corner) THEN
6734  DO j=0,2
6735  vtmp(npx, npy+j) = -utmp(ie-j, npy)
6736  END DO
6737  END IF
6738  IF (gridstruct%sw_corner) THEN
6739  va(0, -1) = -ua(2, 0)
6740  va(0, 0) = -ua(1, 0)
6741  END IF
6742  IF (gridstruct%se_corner) THEN
6743  va(npx, 0) = ua(npx-1, 0)
6744  va(npx, -1) = ua(npx-2, 0)
6745  END IF
6746  IF (gridstruct%ne_corner) THEN
6747  va(npx, npy) = -ua(npx-1, npy)
6748  va(npx, npy+1) = -ua(npx-2, npy)
6749  END IF
6750  IF (gridstruct%nw_corner) THEN
6751  va(0, npy) = ua(1, npy)
6752  va(0, npy+1) = ua(2, npy)
6753  END IF
6754  IF (grid_type .LT. 3) THEN
6755  DO j=js-1,je+2
6756  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
6757  DO i=is-1,ie+1
6758  vt(i, j) = edge_interpolate4(va(i, -1:2), dya(i, -1:2))
6759  IF (vt(i, j) .GT. 0.) THEN
6760  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
6761  ELSE
6762  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
6763  END IF
6764  END DO
6765  ELSE IF (j .EQ. 0 .OR. (j .EQ. npy - 1 .AND. (.NOT.nested))) &
6766 & THEN
6767  DO i=is-1,ie+1
6768  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
6769  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6770  END DO
6771  ELSE IF (j .EQ. 2 .OR. (j .EQ. npy + 1 .AND. (.NOT.nested))) &
6772 & THEN
6773  DO i=is-1,ie+1
6774  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
6775  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6776  END DO
6777  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
6778  DO i=is-1,ie+1
6779  vt(i, j) = edge_interpolate4(va(i, j-2:j+1), dya(i, j-2:j+1)&
6780 & )
6781  IF (vt(i, j) .GT. 0.) THEN
6782  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
6783  ELSE
6784  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
6785  END IF
6786  END DO
6787  ELSE
6788 ! 4th order interpolation for interior points:
6789  DO i=is-1,ie+1
6790  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
6791 & +vtmp(i, j))
6792  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
6793  END DO
6794  END IF
6795  END DO
6796  ELSE
6797 ! 4th order interpolation:
6798  DO j=js-1,je+2
6799  DO i=is-1,ie+1
6800  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
6801 & vtmp(i, j))
6802  vt(i, j) = vc(i, j)
6803  END DO
6804  END DO
6805  END IF
6806  END SUBROUTINE d2a2c_vect
6807 ! Differentiation of edge_interpolate4 in forward (tangent) mode:
6808 ! variations of useful results: edge_interpolate4
6809 ! with respect to varying inputs: ua
6810  REAL FUNCTION edge_interpolate4_tlm(ua, ua_tl, dxa, edge_interpolate4)
6811  IMPLICIT NONE
6812  REAL, INTENT(IN) :: ua(4)
6813  REAL, INTENT(IN) :: ua_tl(4)
6814  REAL, INTENT(IN) :: dxa(4)
6815  REAL :: t1, t2
6816  REAL :: edge_interpolate4
6817  t1 = dxa(1) + dxa(2)
6818  t2 = dxa(3) + dxa(4)
6819  edge_interpolate4_tlm = 0.5*(((t1+dxa(2))*ua_tl(2)-dxa(2)*ua_tl(1))/&
6820 & t1+((t2+dxa(3))*ua_tl(3)-dxa(3)*ua_tl(4))/t2)
6821  edge_interpolate4 = 0.5*(((t1+dxa(2))*ua(2)-dxa(2)*ua(1))/t1+((t2+&
6822 & dxa(3))*ua(3)-dxa(3)*ua(4))/t2)
6823  END FUNCTION edge_interpolate4_tlm
6824  REAL FUNCTION edge_interpolate4(ua, dxa)
6825  IMPLICIT NONE
6826  REAL, INTENT(IN) :: ua(4)
6827  REAL, INTENT(IN) :: dxa(4)
6828  REAL :: t1, t2
6829  t1 = dxa(1) + dxa(2)
6830  t2 = dxa(3) + dxa(4)
6831  edge_interpolate4 = 0.5*(((t1+dxa(2))*ua(2)-dxa(2)*ua(1))/t1+((t2+&
6832 & dxa(3))*ua(3)-dxa(3)*ua(4))/t2)
6833  END FUNCTION edge_interpolate4
6834  SUBROUTINE fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, &
6835 & se_corner, ne_corner, nw_corner)
6836  IMPLICIT NONE
6837  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6838 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
6839 ! 1: x-dir; 2: y-dir
6840  INTEGER, INTENT(IN) :: dir
6841  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
6842  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
6843  REAL, INTENT(INOUT) :: q3(bd%isd:bd%ied, bd%jsd:bd%jed)
6844  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
6845  INTEGER, INTENT(IN) :: npx, npy
6846  INTEGER :: i, j
6847  INTEGER :: is, ie, js, je
6848  INTEGER :: isd, ied, jsd, jed
6849  is = bd%is
6850  ie = bd%ie
6851  js = bd%js
6852  je = bd%je
6853  isd = bd%isd
6854  ied = bd%ied
6855  jsd = bd%jsd
6856  jed = bd%jed
6857  SELECT CASE (dir)
6858  CASE (1)
6859  IF (sw_corner) THEN
6860  q1(-1, 0) = q1(0, 2)
6861  q1(0, 0) = q1(0, 1)
6862  q1(0, -1) = q1(-1, 1)
6863  q2(-1, 0) = q2(0, 2)
6864  q2(0, 0) = q2(0, 1)
6865  q2(0, -1) = q2(-1, 1)
6866  q3(-1, 0) = q3(0, 2)
6867  q3(0, 0) = q3(0, 1)
6868  q3(0, -1) = q3(-1, 1)
6869  END IF
6870  IF (se_corner) THEN
6871  q1(npx+1, 0) = q1(npx, 2)
6872  q1(npx, 0) = q1(npx, 1)
6873  q1(npx, -1) = q1(npx+1, 1)
6874  q2(npx+1, 0) = q2(npx, 2)
6875  q2(npx, 0) = q2(npx, 1)
6876  q2(npx, -1) = q2(npx+1, 1)
6877  q3(npx+1, 0) = q3(npx, 2)
6878  q3(npx, 0) = q3(npx, 1)
6879  q3(npx, -1) = q3(npx+1, 1)
6880  END IF
6881  IF (ne_corner) THEN
6882  q1(npx, npy) = q1(npx, npy-1)
6883  q1(npx+1, npy) = q1(npx, npy-2)
6884  q1(npx, npy+1) = q1(npx+1, npy-1)
6885  q2(npx, npy) = q2(npx, npy-1)
6886  q2(npx+1, npy) = q2(npx, npy-2)
6887  q2(npx, npy+1) = q2(npx+1, npy-1)
6888  q3(npx, npy) = q3(npx, npy-1)
6889  q3(npx+1, npy) = q3(npx, npy-2)
6890  q3(npx, npy+1) = q3(npx+1, npy-1)
6891  END IF
6892  IF (nw_corner) THEN
6893  q1(0, npy) = q1(0, npy-1)
6894  q1(-1, npy) = q1(0, npy-2)
6895  q1(0, npy+1) = q1(-1, npy-1)
6896  q2(0, npy) = q2(0, npy-1)
6897  q2(-1, npy) = q2(0, npy-2)
6898  q2(0, npy+1) = q2(-1, npy-1)
6899  q3(0, npy) = q3(0, npy-1)
6900  q3(-1, npy) = q3(0, npy-2)
6901  q3(0, npy+1) = q3(-1, npy-1)
6902  END IF
6903  CASE (2)
6904  IF (sw_corner) THEN
6905  q1(0, 0) = q1(1, 0)
6906  q1(0, -1) = q1(2, 0)
6907  q1(-1, 0) = q1(1, -1)
6908  q2(0, 0) = q2(1, 0)
6909  q2(0, -1) = q2(2, 0)
6910  q2(-1, 0) = q2(1, -1)
6911  q3(0, 0) = q3(1, 0)
6912  q3(0, -1) = q3(2, 0)
6913  q3(-1, 0) = q3(1, -1)
6914  END IF
6915  IF (se_corner) THEN
6916  q1(npx, 0) = q1(npx-1, 0)
6917  q1(npx, -1) = q1(npx-2, 0)
6918  q1(npx+1, 0) = q1(npx-1, -1)
6919  q2(npx, 0) = q2(npx-1, 0)
6920  q2(npx, -1) = q2(npx-2, 0)
6921  q2(npx+1, 0) = q2(npx-1, -1)
6922  q3(npx, 0) = q3(npx-1, 0)
6923  q3(npx, -1) = q3(npx-2, 0)
6924  q3(npx+1, 0) = q3(npx-1, -1)
6925  END IF
6926  IF (ne_corner) THEN
6927  q1(npx, npy) = q1(npx-1, npy)
6928  q1(npx, npy+1) = q1(npx-2, npy)
6929  q1(npx+1, npy) = q1(npx-1, npy+1)
6930  q2(npx, npy) = q2(npx-1, npy)
6931  q2(npx, npy+1) = q2(npx-2, npy)
6932  q2(npx+1, npy) = q2(npx-1, npy+1)
6933  q3(npx, npy) = q3(npx-1, npy)
6934  q3(npx, npy+1) = q3(npx-2, npy)
6935  q3(npx+1, npy) = q3(npx-1, npy+1)
6936  END IF
6937  IF (nw_corner) THEN
6938  q1(0, npy) = q1(1, npy)
6939  q1(0, npy+1) = q1(2, npy)
6940  q1(-1, npy) = q1(1, npy+1)
6941  q2(0, npy) = q2(1, npy)
6942  q2(0, npy+1) = q2(2, npy)
6943  q2(-1, npy) = q2(1, npy+1)
6944  q3(0, npy) = q3(1, npy)
6945  q3(0, npy+1) = q3(2, npy)
6946  q3(-1, npy) = q3(1, npy+1)
6947  END IF
6948  END SELECT
6949  END SUBROUTINE fill3_4corners
6950 ! Differentiation of fill2_4corners in forward (tangent) mode:
6951 ! variations of useful results: q1 q2
6952 ! with respect to varying inputs: q1 q2
6953  SUBROUTINE fill2_4corners_tlm(q1, q1_tl, q2, q2_tl, dir, bd, npx, npy&
6954 & , sw_corner, se_corner, ne_corner, nw_corner)
6955  IMPLICIT NONE
6956  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6957 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
6958 ! 1: x-dir; 2: y-dir
6959  INTEGER, INTENT(IN) :: dir
6960  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
6961  REAL, INTENT(INOUT) :: q1_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
6962  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
6963  REAL, INTENT(INOUT) :: q2_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
6964  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
6965  INTEGER, INTENT(IN) :: npx, npy
6966  INTEGER :: is, ie, js, je
6967  INTEGER :: isd, ied, jsd, jed
6968  is = bd%is
6969  ie = bd%ie
6970  js = bd%js
6971  je = bd%je
6972  isd = bd%isd
6973  ied = bd%ied
6974  jsd = bd%jsd
6975  jed = bd%jed
6976  SELECT CASE (dir)
6977  CASE (1)
6978  IF (sw_corner) THEN
6979  q1_tl(-1, 0) = q1_tl(0, 2)
6980  q1(-1, 0) = q1(0, 2)
6981  q1_tl(0, 0) = q1_tl(0, 1)
6982  q1(0, 0) = q1(0, 1)
6983  q2_tl(-1, 0) = q2_tl(0, 2)
6984  q2(-1, 0) = q2(0, 2)
6985  q2_tl(0, 0) = q2_tl(0, 1)
6986  q2(0, 0) = q2(0, 1)
6987  END IF
6988  IF (se_corner) THEN
6989  q1_tl(npx+1, 0) = q1_tl(npx, 2)
6990  q1(npx+1, 0) = q1(npx, 2)
6991  q1_tl(npx, 0) = q1_tl(npx, 1)
6992  q1(npx, 0) = q1(npx, 1)
6993  q2_tl(npx+1, 0) = q2_tl(npx, 2)
6994  q2(npx+1, 0) = q2(npx, 2)
6995  q2_tl(npx, 0) = q2_tl(npx, 1)
6996  q2(npx, 0) = q2(npx, 1)
6997  END IF
6998  IF (nw_corner) THEN
6999  q1_tl(0, npy) = q1_tl(0, npy-1)
7000  q1(0, npy) = q1(0, npy-1)
7001  q1_tl(-1, npy) = q1_tl(0, npy-2)
7002  q1(-1, npy) = q1(0, npy-2)
7003  q2_tl(0, npy) = q2_tl(0, npy-1)
7004  q2(0, npy) = q2(0, npy-1)
7005  q2_tl(-1, npy) = q2_tl(0, npy-2)
7006  q2(-1, npy) = q2(0, npy-2)
7007  END IF
7008  IF (ne_corner) THEN
7009  q1_tl(npx, npy) = q1_tl(npx, npy-1)
7010  q1(npx, npy) = q1(npx, npy-1)
7011  q1_tl(npx+1, npy) = q1_tl(npx, npy-2)
7012  q1(npx+1, npy) = q1(npx, npy-2)
7013  q2_tl(npx, npy) = q2_tl(npx, npy-1)
7014  q2(npx, npy) = q2(npx, npy-1)
7015  q2_tl(npx+1, npy) = q2_tl(npx, npy-2)
7016  q2(npx+1, npy) = q2(npx, npy-2)
7017  END IF
7018  CASE (2)
7019  IF (sw_corner) THEN
7020  q1_tl(0, 0) = q1_tl(1, 0)
7021  q1(0, 0) = q1(1, 0)
7022  q1_tl(0, -1) = q1_tl(2, 0)
7023  q1(0, -1) = q1(2, 0)
7024  q2_tl(0, 0) = q2_tl(1, 0)
7025  q2(0, 0) = q2(1, 0)
7026  q2_tl(0, -1) = q2_tl(2, 0)
7027  q2(0, -1) = q2(2, 0)
7028  END IF
7029  IF (se_corner) THEN
7030  q1_tl(npx, 0) = q1_tl(npx-1, 0)
7031  q1(npx, 0) = q1(npx-1, 0)
7032  q1_tl(npx, -1) = q1_tl(npx-2, 0)
7033  q1(npx, -1) = q1(npx-2, 0)
7034  q2_tl(npx, 0) = q2_tl(npx-1, 0)
7035  q2(npx, 0) = q2(npx-1, 0)
7036  q2_tl(npx, -1) = q2_tl(npx-2, 0)
7037  q2(npx, -1) = q2(npx-2, 0)
7038  END IF
7039  IF (nw_corner) THEN
7040  q1_tl(0, npy) = q1_tl(1, npy)
7041  q1(0, npy) = q1(1, npy)
7042  q1_tl(0, npy+1) = q1_tl(2, npy)
7043  q1(0, npy+1) = q1(2, npy)
7044  q2_tl(0, npy) = q2_tl(1, npy)
7045  q2(0, npy) = q2(1, npy)
7046  q2_tl(0, npy+1) = q2_tl(2, npy)
7047  q2(0, npy+1) = q2(2, npy)
7048  END IF
7049  IF (ne_corner) THEN
7050  q1_tl(npx, npy) = q1_tl(npx-1, npy)
7051  q1(npx, npy) = q1(npx-1, npy)
7052  q1_tl(npx, npy+1) = q1_tl(npx-2, npy)
7053  q1(npx, npy+1) = q1(npx-2, npy)
7054  q2_tl(npx, npy) = q2_tl(npx-1, npy)
7055  q2(npx, npy) = q2(npx-1, npy)
7056  q2_tl(npx, npy+1) = q2_tl(npx-2, npy)
7057  q2(npx, npy+1) = q2(npx-2, npy)
7058  END IF
7059  END SELECT
7060  END SUBROUTINE fill2_4corners_tlm
7061  SUBROUTINE fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, &
7062 & se_corner, ne_corner, nw_corner)
7063  IMPLICIT NONE
7064  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7065 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
7066 ! 1: x-dir; 2: y-dir
7067  INTEGER, INTENT(IN) :: dir
7068  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
7069  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
7070  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
7071  INTEGER, INTENT(IN) :: npx, npy
7072  INTEGER :: is, ie, js, je
7073  INTEGER :: isd, ied, jsd, jed
7074  is = bd%is
7075  ie = bd%ie
7076  js = bd%js
7077  je = bd%je
7078  isd = bd%isd
7079  ied = bd%ied
7080  jsd = bd%jsd
7081  jed = bd%jed
7082  SELECT CASE (dir)
7083  CASE (1)
7084  IF (sw_corner) THEN
7085  q1(-1, 0) = q1(0, 2)
7086  q1(0, 0) = q1(0, 1)
7087  q2(-1, 0) = q2(0, 2)
7088  q2(0, 0) = q2(0, 1)
7089  END IF
7090  IF (se_corner) THEN
7091  q1(npx+1, 0) = q1(npx, 2)
7092  q1(npx, 0) = q1(npx, 1)
7093  q2(npx+1, 0) = q2(npx, 2)
7094  q2(npx, 0) = q2(npx, 1)
7095  END IF
7096  IF (nw_corner) THEN
7097  q1(0, npy) = q1(0, npy-1)
7098  q1(-1, npy) = q1(0, npy-2)
7099  q2(0, npy) = q2(0, npy-1)
7100  q2(-1, npy) = q2(0, npy-2)
7101  END IF
7102  IF (ne_corner) THEN
7103  q1(npx, npy) = q1(npx, npy-1)
7104  q1(npx+1, npy) = q1(npx, npy-2)
7105  q2(npx, npy) = q2(npx, npy-1)
7106  q2(npx+1, npy) = q2(npx, npy-2)
7107  END IF
7108  CASE (2)
7109  IF (sw_corner) THEN
7110  q1(0, 0) = q1(1, 0)
7111  q1(0, -1) = q1(2, 0)
7112  q2(0, 0) = q2(1, 0)
7113  q2(0, -1) = q2(2, 0)
7114  END IF
7115  IF (se_corner) THEN
7116  q1(npx, 0) = q1(npx-1, 0)
7117  q1(npx, -1) = q1(npx-2, 0)
7118  q2(npx, 0) = q2(npx-1, 0)
7119  q2(npx, -1) = q2(npx-2, 0)
7120  END IF
7121  IF (nw_corner) THEN
7122  q1(0, npy) = q1(1, npy)
7123  q1(0, npy+1) = q1(2, npy)
7124  q2(0, npy) = q2(1, npy)
7125  q2(0, npy+1) = q2(2, npy)
7126  END IF
7127  IF (ne_corner) THEN
7128  q1(npx, npy) = q1(npx-1, npy)
7129  q1(npx, npy+1) = q1(npx-2, npy)
7130  q2(npx, npy) = q2(npx-1, npy)
7131  q2(npx, npy+1) = q2(npx-2, npy)
7132  END IF
7133  END SELECT
7134  END SUBROUTINE fill2_4corners
7135 ! Differentiation of fill_4corners in forward (tangent) mode:
7136 ! variations of useful results: q
7137 ! with respect to varying inputs: q
7138  SUBROUTINE fill_4corners_tlm(q, q_tl, dir, bd, npx, npy, sw_corner, &
7139 & se_corner, ne_corner, nw_corner)
7140  IMPLICIT NONE
7141  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7142 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
7143 ! 1: x-dir; 2: y-dir
7144  INTEGER, INTENT(IN) :: dir
7145  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
7146  REAL, INTENT(INOUT) :: q_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
7147  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
7148  INTEGER, INTENT(IN) :: npx, npy
7149  INTEGER :: is, ie, js, je
7150  INTEGER :: isd, ied, jsd, jed
7151  is = bd%is
7152  ie = bd%ie
7153  js = bd%js
7154  je = bd%je
7155  isd = bd%isd
7156  ied = bd%ied
7157  jsd = bd%jsd
7158  jed = bd%jed
7159  SELECT CASE (dir)
7160  CASE (1)
7161  IF (sw_corner) THEN
7162  q_tl(-1, 0) = q_tl(0, 2)
7163  q(-1, 0) = q(0, 2)
7164  q_tl(0, 0) = q_tl(0, 1)
7165  q(0, 0) = q(0, 1)
7166  END IF
7167  IF (se_corner) THEN
7168  q_tl(npx+1, 0) = q_tl(npx, 2)
7169  q(npx+1, 0) = q(npx, 2)
7170  q_tl(npx, 0) = q_tl(npx, 1)
7171  q(npx, 0) = q(npx, 1)
7172  END IF
7173  IF (nw_corner) THEN
7174  q_tl(0, npy) = q_tl(0, npy-1)
7175  q(0, npy) = q(0, npy-1)
7176  q_tl(-1, npy) = q_tl(0, npy-2)
7177  q(-1, npy) = q(0, npy-2)
7178  END IF
7179  IF (ne_corner) THEN
7180  q_tl(npx, npy) = q_tl(npx, npy-1)
7181  q(npx, npy) = q(npx, npy-1)
7182  q_tl(npx+1, npy) = q_tl(npx, npy-2)
7183  q(npx+1, npy) = q(npx, npy-2)
7184  END IF
7185  CASE (2)
7186  IF (sw_corner) THEN
7187  q_tl(0, 0) = q_tl(1, 0)
7188  q(0, 0) = q(1, 0)
7189  q_tl(0, -1) = q_tl(2, 0)
7190  q(0, -1) = q(2, 0)
7191  END IF
7192  IF (se_corner) THEN
7193  q_tl(npx, 0) = q_tl(npx-1, 0)
7194  q(npx, 0) = q(npx-1, 0)
7195  q_tl(npx, -1) = q_tl(npx-2, 0)
7196  q(npx, -1) = q(npx-2, 0)
7197  END IF
7198  IF (nw_corner) THEN
7199  q_tl(0, npy) = q_tl(1, npy)
7200  q(0, npy) = q(1, npy)
7201  q_tl(0, npy+1) = q_tl(2, npy)
7202  q(0, npy+1) = q(2, npy)
7203  END IF
7204  IF (ne_corner) THEN
7205  q_tl(npx, npy) = q_tl(npx-1, npy)
7206  q(npx, npy) = q(npx-1, npy)
7207  q_tl(npx, npy+1) = q_tl(npx-2, npy)
7208  q(npx, npy+1) = q(npx-2, npy)
7209  END IF
7210  END SELECT
7211  END SUBROUTINE fill_4corners_tlm
7212  SUBROUTINE fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, &
7213 & ne_corner, nw_corner)
7214  IMPLICIT NONE
7215  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7216 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
7217 ! 1: x-dir; 2: y-dir
7218  INTEGER, INTENT(IN) :: dir
7219  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
7220  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
7221  INTEGER, INTENT(IN) :: npx, npy
7222  INTEGER :: is, ie, js, je
7223  INTEGER :: isd, ied, jsd, jed
7224  is = bd%is
7225  ie = bd%ie
7226  js = bd%js
7227  je = bd%je
7228  isd = bd%isd
7229  ied = bd%ied
7230  jsd = bd%jsd
7231  jed = bd%jed
7232  SELECT CASE (dir)
7233  CASE (1)
7234  IF (sw_corner) THEN
7235  q(-1, 0) = q(0, 2)
7236  q(0, 0) = q(0, 1)
7237  END IF
7238  IF (se_corner) THEN
7239  q(npx+1, 0) = q(npx, 2)
7240  q(npx, 0) = q(npx, 1)
7241  END IF
7242  IF (nw_corner) THEN
7243  q(0, npy) = q(0, npy-1)
7244  q(-1, npy) = q(0, npy-2)
7245  END IF
7246  IF (ne_corner) THEN
7247  q(npx, npy) = q(npx, npy-1)
7248  q(npx+1, npy) = q(npx, npy-2)
7249  END IF
7250  CASE (2)
7251  IF (sw_corner) THEN
7252  q(0, 0) = q(1, 0)
7253  q(0, -1) = q(2, 0)
7254  END IF
7255  IF (se_corner) THEN
7256  q(npx, 0) = q(npx-1, 0)
7257  q(npx, -1) = q(npx-2, 0)
7258  END IF
7259  IF (nw_corner) THEN
7260  q(0, npy) = q(1, npy)
7261  q(0, npy+1) = q(2, npy)
7262  END IF
7263  IF (ne_corner) THEN
7264  q(npx, npy) = q(npx-1, npy)
7265  q(npx, npy+1) = q(npx-2, npy)
7266  END IF
7267  END SELECT
7268  END SUBROUTINE fill_4corners
7269 ! Differentiation of xtp_u in forward (tangent) mode:
7270 ! variations of useful results: flux
7271 ! with respect to varying inputs: flux u c
7272  SUBROUTINE xtp_u_tlm(is, ie, js, je, isd, ied, jsd, jed, c, c_tl, u&
7273 & , u_tl, v, flux, flux_tl, iord, dx, rdx, npx, npy, grid_type, nested&
7274 & )
7275  IMPLICIT NONE
7276  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
7277  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
7278  REAL, INTENT(IN) :: u_tl(isd:ied, jsd:jed+1)
7279  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
7280  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
7281  REAL, INTENT(IN) :: c_tl(is:ie+1, js:je+1)
7282  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
7283  REAL, INTENT(OUT) :: flux_tl(is:ie+1, js:je+1)
7284  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
7285  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
7286  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
7287  LOGICAL, INTENT(IN) :: nested
7288 ! Local
7289  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
7290  REAL, DIMENSION(is-1:ie+1) :: bl_tl, br_tl, b0_tl
7291  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
7292  REAL :: fx0(is:ie+1)
7293  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
7294  REAL :: al_tl(is-1:ie+2)
7295  REAL :: dq(is-3:ie+2)
7296  REAL :: dl, dr, xt, pmp, lac, cfl
7297  REAL :: xt_tl, cfl_tl
7298  REAL :: pmp_1, lac_1, pmp_2, lac_2
7299  REAL :: x0, x1, x0l, x0r
7300  INTEGER :: i, j
7301  INTEGER :: is3, ie3
7302  INTEGER :: is2, ie2
7303  INTRINSIC max
7304  INTRINSIC min
7305  IF (nested .OR. grid_type .GT. 3) THEN
7306  is3 = is - 1
7307  ie3 = ie + 1
7308  ELSE
7309  IF (3 .LT. is - 1) THEN
7310  is3 = is - 1
7311  ELSE
7312  is3 = 3
7313  END IF
7314  IF (npx - 3 .GT. ie + 1) THEN
7315  ie3 = ie + 1
7316  ELSE
7317  ie3 = npx - 3
7318  END IF
7319  END IF
7320  IF (iord .EQ. 1) THEN
7321  DO j=js,je+1
7322  DO i=is,ie+1
7323  IF (c(i, j) .GT. 0.) THEN
7324  flux_tl(i, j) = u_tl(i-1, j)
7325  flux(i, j) = u(i-1, j)
7326  ELSE
7327  flux_tl(i, j) = u_tl(i, j)
7328  flux(i, j) = u(i, j)
7329  END IF
7330  END DO
7331  END DO
7332  ELSE IF (iord .EQ. 333) THEN
7333  DO j=js,je+1
7334  DO i=is,ie+1
7335  IF (c(i, j) .GT. 0.) THEN
7336  flux_tl(i, j) = (2.0*u_tl(i, j)+5.0*u_tl(i-1, j)-u_tl(i-2, j&
7337 & ))/6.0 - 0.5*rdx(i-1, j)*(c_tl(i, j)*(u(i, j)-u(i-1, j))+c&
7338 & (i, j)*(u_tl(i, j)-u_tl(i-1, j))) + rdx(i-1, j)**2*(c_tl(i&
7339 & , j)*c(i, j)+c(i, j)*c_tl(i, j))*(u(i, j)-2.0*u(i-1, j)+u(&
7340 & i-2, j))/6.0 + c(i, j)**2*rdx(i-1, j)**2*(u_tl(i, j)-2.0*&
7341 & u_tl(i-1, j)+u_tl(i-2, j))/6.0
7342  flux(i, j) = (2.0*u(i, j)+5.0*u(i-1, j)-u(i-2, j))/6.0 - 0.5&
7343 & *c(i, j)*rdx(i-1, j)*(u(i, j)-u(i-1, j)) + c(i, j)*rdx(i-1&
7344 & , j)*c(i, j)*rdx(i-1, j)/6.0*(u(i, j)-2.0*u(i-1, j)+u(i-2&
7345 & , j))
7346  ELSE
7347  flux_tl(i, j) = (2.0*u_tl(i-1, j)+5.0*u_tl(i, j)-u_tl(i+1, j&
7348 & ))/6.0 - 0.5*rdx(i, j)*(c_tl(i, j)*(u(i, j)-u(i-1, j))+c(i&
7349 & , j)*(u_tl(i, j)-u_tl(i-1, j))) + rdx(i, j)**2*(c_tl(i, j)&
7350 & *c(i, j)+c(i, j)*c_tl(i, j))*(u(i+1, j)-2.0*u(i, j)+u(i-1&
7351 & , j))/6.0 + c(i, j)**2*rdx(i, j)**2*(u_tl(i+1, j)-2.0*u_tl&
7352 & (i, j)+u_tl(i-1, j))/6.0
7353  flux(i, j) = (2.0*u(i-1, j)+5.0*u(i, j)-u(i+1, j))/6.0 - 0.5&
7354 & *c(i, j)*rdx(i, j)*(u(i, j)-u(i-1, j)) + c(i, j)*rdx(i, j)&
7355 & *c(i, j)*rdx(i, j)/6.0*(u(i+1, j)-2.0*u(i, j)+u(i-1, j))
7356  END IF
7357  END DO
7358  END DO
7359  ELSE IF (iord .LT. 8) THEN
7360  al_tl = 0.0
7361  bl_tl = 0.0
7362  br_tl = 0.0
7363  b0_tl = 0.0
7364 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
7365  DO j=js,je+1
7366  DO i=is3,ie3+1
7367  al_tl(i) = p1*(u_tl(i-1, j)+u_tl(i, j)) + p2*(u_tl(i-2, j)+&
7368 & u_tl(i+1, j))
7369  al(i) = p1*(u(i-1, j)+u(i, j)) + p2*(u(i-2, j)+u(i+1, j))
7370  END DO
7371  DO i=is3,ie3
7372  bl_tl(i) = al_tl(i) - u_tl(i, j)
7373  bl(i) = al(i) - u(i, j)
7374  br_tl(i) = al_tl(i+1) - u_tl(i, j)
7375  br(i) = al(i+1) - u(i, j)
7376  END DO
7377  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
7378  IF (is .EQ. 1) THEN
7379  xt_tl = c3*u_tl(1, j) + c2*u_tl(2, j) + c1*u_tl(3, j)
7380  xt = c3*u(1, j) + c2*u(2, j) + c1*u(3, j)
7381  br_tl(1) = xt_tl - u_tl(1, j)
7382  br(1) = xt - u(1, j)
7383  bl_tl(2) = xt_tl - u_tl(2, j)
7384  bl(2) = xt - u(2, j)
7385  br_tl(2) = al_tl(3) - u_tl(2, j)
7386  br(2) = al(3) - u(2, j)
7387  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
7388 ! out
7389  bl_tl(0) = 0.0
7390  bl(0) = 0.
7391 ! edge
7392  br_tl(0) = 0.0
7393  br(0) = 0.
7394 ! edge
7395  bl_tl(1) = 0.0
7396  bl(1) = 0.
7397 ! in
7398  br_tl(1) = 0.0
7399  br(1) = 0.
7400  ELSE
7401  bl_tl(0) = c1*u_tl(-2, j) + c2*u_tl(-1, j) + c3*u_tl(0, j)&
7402 & - u_tl(0, j)
7403  bl(0) = c1*u(-2, j) + c2*u(-1, j) + c3*u(0, j) - u(0, j)
7404  xt_tl = 0.5*(((2.*dx(0, j)+dx(-1, j))*u_tl(0, j)-dx(0, j)*&
7405 & u_tl(-1, j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j)&
7406 & )*u_tl(1, j)-dx(1, j)*u_tl(2, j))/(dx(1, j)+dx(2, j)))
7407  xt = 0.5*(((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
7408 & j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j))*u(1, j)&
7409 & -dx(1, j)*u(2, j))/(dx(1, j)+dx(2, j)))
7410  br_tl(0) = xt_tl - u_tl(0, j)
7411  br(0) = xt - u(0, j)
7412  bl_tl(1) = xt_tl - u_tl(1, j)
7413  bl(1) = xt - u(1, j)
7414  END IF
7415  END IF
7416 ! call pert_ppm(1, u(2,j), bl(2), br(2), -1)
7417  IF (ie + 1 .EQ. npx) THEN
7418  bl_tl(npx-2) = al_tl(npx-2) - u_tl(npx-2, j)
7419  bl(npx-2) = al(npx-2) - u(npx-2, j)
7420  xt_tl = c1*u_tl(npx-3, j) + c2*u_tl(npx-2, j) + c3*u_tl(npx-&
7421 & 1, j)
7422  xt = c1*u(npx-3, j) + c2*u(npx-2, j) + c3*u(npx-1, j)
7423  br_tl(npx-2) = xt_tl - u_tl(npx-2, j)
7424  br(npx-2) = xt - u(npx-2, j)
7425  bl_tl(npx-1) = xt_tl - u_tl(npx-1, j)
7426  bl(npx-1) = xt - u(npx-1, j)
7427  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
7428 ! in
7429  bl_tl(npx-1) = 0.0
7430  bl(npx-1) = 0.
7431 ! edge
7432  br_tl(npx-1) = 0.0
7433  br(npx-1) = 0.
7434 ! edge
7435  bl_tl(npx) = 0.0
7436  bl(npx) = 0.
7437 ! out
7438  br_tl(npx) = 0.0
7439  br(npx) = 0.
7440  ELSE
7441  xt_tl = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u_tl(npx-1, j&
7442 & )-dx(npx-1, j)*u_tl(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j&
7443 & ))+((2.*dx(npx, j)+dx(npx+1, j))*u_tl(npx, j)-dx(npx, j)&
7444 & *u_tl(npx+1, j))/(dx(npx, j)+dx(npx+1, j)))
7445  xt = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
7446 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))+((2.*&
7447 & dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, j)*u(npx+1, j&
7448 & ))/(dx(npx, j)+dx(npx+1, j)))
7449  br_tl(npx-1) = xt_tl - u_tl(npx-1, j)
7450  br(npx-1) = xt - u(npx-1, j)
7451  bl_tl(npx) = xt_tl - u_tl(npx, j)
7452  bl(npx) = xt - u(npx, j)
7453  br_tl(npx) = c3*u_tl(npx, j) + c2*u_tl(npx+1, j) + c1*u_tl&
7454 & (npx+2, j) - u_tl(npx, j)
7455  br(npx) = c3*u(npx, j) + c2*u(npx+1, j) + c1*u(npx+2, j) -&
7456 & u(npx, j)
7457  END IF
7458  END IF
7459  END IF
7460 ! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
7461  DO i=is-1,ie+1
7462  b0_tl(i) = bl_tl(i) + br_tl(i)
7463  b0(i) = bl(i) + br(i)
7464  END DO
7465  IF (iord .EQ. 2) THEN
7466 ! Perfectly linear
7467 !DEC$ VECTOR ALWAYS
7468  DO i=is,ie+1
7469  IF (c(i, j) .GT. 0.) THEN
7470  cfl_tl = rdx(i-1, j)*c_tl(i, j)
7471  cfl = c(i, j)*rdx(i-1, j)
7472  flux_tl(i, j) = u_tl(i-1, j) + (1.-cfl)*(br_tl(i-1)-cfl_tl&
7473 & *b0(i-1)-cfl*b0_tl(i-1)) - cfl_tl*(br(i-1)-cfl*b0(i-1))
7474  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
7475  ELSE
7476  cfl_tl = rdx(i, j)*c_tl(i, j)
7477  cfl = c(i, j)*rdx(i, j)
7478  flux_tl(i, j) = u_tl(i, j) + cfl_tl*(bl(i)+cfl*b0(i)) + (&
7479 & 1.+cfl)*(bl_tl(i)+cfl_tl*b0(i)+cfl*b0_tl(i))
7480  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
7481  END IF
7482  END DO
7483  END IF
7484  END DO
7485  END IF
7486  END SUBROUTINE xtp_u_tlm
7487 ! Differentiation of ytp_v in forward (tangent) mode:
7488 ! variations of useful results: flux
7489 ! with respect to varying inputs: v c
7490  SUBROUTINE ytp_v_tlm(is, ie, js, je, isd, ied, jsd, jed, c, c_tl, u&
7491 & , v, v_tl, flux, flux_tl, jord, dy, rdy, npx, npy, grid_type, nested&
7492 & )
7493  IMPLICIT NONE
7494  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
7495  INTEGER, INTENT(IN) :: jord
7496  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
7497  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
7498  REAL, INTENT(IN) :: v_tl(isd:ied+1, jsd:jed)
7499 ! Courant N (like FLUX)
7500  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
7501  REAL, INTENT(IN) :: c_tl(is:ie+1, js:je+1)
7502  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
7503  REAL, INTENT(OUT) :: flux_tl(is:ie+1, js:je+1)
7504  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
7505  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
7506  INTEGER, INTENT(IN) :: npx, npy, grid_type
7507  LOGICAL, INTENT(IN) :: nested
7508 ! Local:
7509  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
7510  REAL :: fx0(is:ie+1)
7511  REAL :: dm(is:ie+1, js-2:je+2)
7512  REAL :: al(is:ie+1, js-1:je+2)
7513  REAL :: al_tl(is:ie+1, js-1:je+2)
7514  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
7515  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl_tl, br_tl, b0_tl
7516  REAL :: dq(is:ie+1, js-3:je+2)
7517  REAL :: xt, dl, dr, pmp, lac, cfl
7518  REAL :: xt_tl, cfl_tl
7519  REAL :: pmp_1, lac_1, pmp_2, lac_2
7520  REAL :: x0, x1, x0r, x0l
7521  INTEGER :: i, j, is1, ie1, js3, je3
7522  INTRINSIC max
7523  INTRINSIC min
7524  IF (nested .OR. grid_type .GT. 3) THEN
7525  js3 = js - 1
7526  je3 = je + 1
7527  ELSE
7528  IF (3 .LT. js - 1) THEN
7529  js3 = js - 1
7530  ELSE
7531  js3 = 3
7532  END IF
7533  IF (npy - 3 .GT. je + 1) THEN
7534  je3 = je + 1
7535  ELSE
7536  je3 = npy - 3
7537  END IF
7538  END IF
7539  IF (jord .EQ. 1) THEN
7540  flux_tl = 0.0
7541  DO j=js,je+1
7542  DO i=is,ie+1
7543  IF (c(i, j) .GT. 0.) THEN
7544  flux_tl(i, j) = v_tl(i, j-1)
7545  flux(i, j) = v(i, j-1)
7546  ELSE
7547  flux_tl(i, j) = v_tl(i, j)
7548  flux(i, j) = v(i, j)
7549  END IF
7550  END DO
7551  END DO
7552  ELSE IF (jord .EQ. 333) THEN
7553  flux_tl = 0.0
7554  DO j=js,je+1
7555  DO i=is,ie+1
7556  IF (c(i, j) .GT. 0.) THEN
7557  flux_tl(i, j) = (2.0*v_tl(i, j)+5.0*v_tl(i, j-1)-v_tl(i, j-2&
7558 & ))/6.0 - 0.5*rdy(i, j-1)*(c_tl(i, j)*(v(i, j)-v(i, j-1))+c&
7559 & (i, j)*(v_tl(i, j)-v_tl(i, j-1))) + rdy(i, j-1)**2*(c_tl(i&
7560 & , j)*c(i, j)+c(i, j)*c_tl(i, j))*(v(i, j)-2.0*v(i, j-1)+v(&
7561 & i, j-2))/6.0 + c(i, j)**2*rdy(i, j-1)**2*(v_tl(i, j)-2.0*&
7562 & v_tl(i, j-1)+v_tl(i, j-2))/6.0
7563  flux(i, j) = (2.0*v(i, j)+5.0*v(i, j-1)-v(i, j-2))/6.0 - 0.5&
7564 & *c(i, j)*rdy(i, j-1)*(v(i, j)-v(i, j-1)) + c(i, j)*rdy(i, &
7565 & j-1)*c(i, j)*rdy(i, j-1)/6.0*(v(i, j)-2.0*v(i, j-1)+v(i, j&
7566 & -2))
7567  ELSE
7568  flux_tl(i, j) = (2.0*v_tl(i, j-1)+5.0*v_tl(i, j)-v_tl(i, j+1&
7569 & ))/6.0 - 0.5*rdy(i, j)*(c_tl(i, j)*(v(i, j)-v(i, j-1))+c(i&
7570 & , j)*(v_tl(i, j)-v_tl(i, j-1))) + rdy(i, j)**2*(c_tl(i, j)&
7571 & *c(i, j)+c(i, j)*c_tl(i, j))*(v(i, j+1)-2.0*v(i, j)+v(i, j&
7572 & -1))/6.0 + c(i, j)**2*rdy(i, j)**2*(v_tl(i, j+1)-2.0*v_tl(&
7573 & i, j)+v_tl(i, j-1))/6.0
7574  flux(i, j) = (2.0*v(i, j-1)+5.0*v(i, j)-v(i, j+1))/6.0 - 0.5&
7575 & *c(i, j)*rdy(i, j)*(v(i, j)-v(i, j-1)) + c(i, j)*rdy(i, j)&
7576 & *c(i, j)*rdy(i, j)/6.0*(v(i, j+1)-2.0*v(i, j)+v(i, j-1))
7577  END IF
7578  END DO
7579  END DO
7580  ELSE IF (jord .LT. 8) THEN
7581  al_tl = 0.0
7582 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
7583  DO j=js3,je3+1
7584  DO i=is,ie+1
7585  al_tl(i, j) = p1*(v_tl(i, j-1)+v_tl(i, j)) + p2*(v_tl(i, j-2)+&
7586 & v_tl(i, j+1))
7587  al(i, j) = p1*(v(i, j-1)+v(i, j)) + p2*(v(i, j-2)+v(i, j+1))
7588  END DO
7589  END DO
7590  bl_tl = 0.0
7591  br_tl = 0.0
7592  DO j=js3,je3
7593  DO i=is,ie+1
7594  bl_tl(i, j) = al_tl(i, j) - v_tl(i, j)
7595  bl(i, j) = al(i, j) - v(i, j)
7596  br_tl(i, j) = al_tl(i, j+1) - v_tl(i, j)
7597  br(i, j) = al(i, j+1) - v(i, j)
7598  END DO
7599  END DO
7600  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
7601  IF (js .EQ. 1) THEN
7602  DO i=is,ie+1
7603  bl_tl(i, 0) = c1*v_tl(i, -2) + c2*v_tl(i, -1) + c3*v_tl(i, 0&
7604 & ) - v_tl(i, 0)
7605  bl(i, 0) = c1*v(i, -2) + c2*v(i, -1) + c3*v(i, 0) - v(i, 0)
7606  xt_tl = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v_tl(i, 0)-dy(i, 0)*&
7607 & v_tl(i, -1))/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*&
7608 & v_tl(i, 1)-dy(i, 1)*v_tl(i, 2))/(dy(i, 1)+dy(i, 2)))
7609  xt = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
7610 & )/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(&
7611 & i, 1)*v(i, 2))/(dy(i, 1)+dy(i, 2)))
7612  br_tl(i, 0) = xt_tl - v_tl(i, 0)
7613  br(i, 0) = xt - v(i, 0)
7614  bl_tl(i, 1) = xt_tl - v_tl(i, 1)
7615  bl(i, 1) = xt - v(i, 1)
7616  xt_tl = c3*v_tl(i, 1) + c2*v_tl(i, 2) + c1*v_tl(i, 3)
7617  xt = c3*v(i, 1) + c2*v(i, 2) + c1*v(i, 3)
7618  br_tl(i, 1) = xt_tl - v_tl(i, 1)
7619  br(i, 1) = xt - v(i, 1)
7620  bl_tl(i, 2) = xt_tl - v_tl(i, 2)
7621  bl(i, 2) = xt - v(i, 2)
7622  br_tl(i, 2) = al_tl(i, 3) - v_tl(i, 2)
7623  br(i, 2) = al(i, 3) - v(i, 2)
7624  END DO
7625  IF (is .EQ. 1) THEN
7626 ! out
7627  bl_tl(1, 0) = 0.0
7628  bl(1, 0) = 0.
7629 ! edge
7630  br_tl(1, 0) = 0.0
7631  br(1, 0) = 0.
7632 ! edge
7633  bl_tl(1, 1) = 0.0
7634  bl(1, 1) = 0.
7635 ! in
7636  br_tl(1, 1) = 0.0
7637  br(1, 1) = 0.
7638  END IF
7639  IF (ie + 1 .EQ. npx) THEN
7640 ! out
7641  bl_tl(npx, 0) = 0.0
7642  bl(npx, 0) = 0.
7643 ! edge
7644  br_tl(npx, 0) = 0.0
7645  br(npx, 0) = 0.
7646 ! edge
7647  bl_tl(npx, 1) = 0.0
7648  bl(npx, 1) = 0.
7649 ! in
7650  br_tl(npx, 1) = 0.0
7651  br(npx, 1) = 0.
7652  END IF
7653  END IF
7654 ! j=2
7655 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
7656  IF (je + 1 .EQ. npy) THEN
7657  DO i=is,ie+1
7658  bl_tl(i, npy-2) = al_tl(i, npy-2) - v_tl(i, npy-2)
7659  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
7660  xt_tl = c1*v_tl(i, npy-3) + c2*v_tl(i, npy-2) + c3*v_tl(i, &
7661 & npy-1)
7662  xt = c1*v(i, npy-3) + c2*v(i, npy-2) + c3*v(i, npy-1)
7663  br_tl(i, npy-2) = xt_tl - v_tl(i, npy-2)
7664  br(i, npy-2) = xt - v(i, npy-2)
7665  bl_tl(i, npy-1) = xt_tl - v_tl(i, npy-1)
7666  bl(i, npy-1) = xt - v(i, npy-1)
7667  xt_tl = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v_tl(i, npy-1)-&
7668 & dy(i, npy-1)*v_tl(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+(&
7669 & (2.*dy(i, npy)+dy(i, npy+1))*v_tl(i, npy)-dy(i, npy)*v_tl(&
7670 & i, npy+1))/(dy(i, npy)+dy(i, npy+1)))
7671  xt = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
7672 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+((2.*dy(i&
7673 & , npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)*v(i, npy+1))/(dy&
7674 & (i, npy)+dy(i, npy+1)))
7675  br_tl(i, npy-1) = xt_tl - v_tl(i, npy-1)
7676  br(i, npy-1) = xt - v(i, npy-1)
7677  bl_tl(i, npy) = xt_tl - v_tl(i, npy)
7678  bl(i, npy) = xt - v(i, npy)
7679  br_tl(i, npy) = c3*v_tl(i, npy) + c2*v_tl(i, npy+1) + c1*&
7680 & v_tl(i, npy+2) - v_tl(i, npy)
7681  br(i, npy) = c3*v(i, npy) + c2*v(i, npy+1) + c1*v(i, npy+2) &
7682 & - v(i, npy)
7683  END DO
7684  IF (is .EQ. 1) THEN
7685 ! in
7686  bl_tl(1, npy-1) = 0.0
7687  bl(1, npy-1) = 0.
7688 ! edge
7689  br_tl(1, npy-1) = 0.0
7690  br(1, npy-1) = 0.
7691 ! edge
7692  bl_tl(1, npy) = 0.0
7693  bl(1, npy) = 0.
7694 ! out
7695  br_tl(1, npy) = 0.0
7696  br(1, npy) = 0.
7697  END IF
7698  IF (ie + 1 .EQ. npx) THEN
7699 ! in
7700  bl_tl(npx, npy-1) = 0.0
7701  bl(npx, npy-1) = 0.
7702 ! edge
7703  br_tl(npx, npy-1) = 0.0
7704  br(npx, npy-1) = 0.
7705 ! edge
7706  bl_tl(npx, npy) = 0.0
7707  bl(npx, npy) = 0.
7708 ! out
7709  br_tl(npx, npy) = 0.0
7710  br(npx, npy) = 0.
7711  b0_tl = 0.0
7712  ELSE
7713  b0_tl = 0.0
7714  END IF
7715  ELSE
7716  b0_tl = 0.0
7717  END IF
7718  ELSE
7719  b0_tl = 0.0
7720  END IF
7721 ! j=npy-2
7722 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
7723  DO j=js-1,je+1
7724  DO i=is,ie+1
7725  b0_tl(i, j) = bl_tl(i, j) + br_tl(i, j)
7726  b0(i, j) = bl(i, j) + br(i, j)
7727  END DO
7728  END DO
7729  IF (jord .EQ. 2) THEN
7730  flux_tl = 0.0
7731 ! Perfectly linear
7732  DO j=js,je+1
7733 !DEC$ VECTOR ALWAYS
7734  DO i=is,ie+1
7735  IF (c(i, j) .GT. 0.) THEN
7736  cfl_tl = rdy(i, j-1)*c_tl(i, j)
7737  cfl = c(i, j)*rdy(i, j-1)
7738  flux_tl(i, j) = v_tl(i, j-1) + (1.-cfl)*(br_tl(i, j-1)-&
7739 & cfl_tl*b0(i, j-1)-cfl*b0_tl(i, j-1)) - cfl_tl*(br(i, j-1&
7740 & )-cfl*b0(i, j-1))
7741  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-&
7742 & 1))
7743  ELSE
7744  cfl_tl = rdy(i, j)*c_tl(i, j)
7745  cfl = c(i, j)*rdy(i, j)
7746  flux_tl(i, j) = v_tl(i, j) + cfl_tl*(bl(i, j)+cfl*b0(i, j)&
7747 & ) + (1.+cfl)*(bl_tl(i, j)+cfl_tl*b0(i, j)+cfl*b0_tl(i, j&
7748 & ))
7749  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
7750  END IF
7751  END DO
7752  END DO
7753  ELSE
7754  flux_tl = 0.0
7755  END IF
7756  ELSE
7757  flux_tl = 0.0
7758  END IF
7759  END SUBROUTINE ytp_v_tlm
7760  SUBROUTINE compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, &
7761 & vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, gridstruct, &
7762 & flagstruct, bd)
7763  IMPLICIT NONE
7764 !InOut Arguments
7765  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7766  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
7767  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
7768  INTEGER, INTENT(IN) :: nord
7769  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
7770  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
7771  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
7772  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
7773 !Intent is really in
7774  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
7775  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
7776  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
7777 & delpc, ptc
7778  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
7779 & ke
7780  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
7781  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
7782  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
7783 & divg_d
7784 !Locals
7785  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
7786  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
7787  LOGICAL :: nested, fill_c
7788  INTEGER :: i, j, n, n2, nt
7789  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
7790  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
7791  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
7792  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
7793  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
7794  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
7795  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
7796  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
7797 & , rdx, rdy
7798  INTRINSIC ABS
7799  INTRINSIC max
7800  INTRINSIC min
7801  INTRINSIC sqrt
7802  REAL :: max1
7803  REAL :: abs0
7804  REAL :: abs1
7805  REAL :: max2
7806  REAL :: abs2
7807  REAL :: arg1
7808  REAL :: result1
7809  REAL :: pwr1
7810  REAL*8 :: pwx1
7811  REAL :: y3
7812  REAL :: y2
7813  REAL :: y1
7814  area => gridstruct%area
7815  rarea => gridstruct%rarea
7816  sin_sg => gridstruct%sin_sg
7817  cosa_u => gridstruct%cosa_u
7818  cosa_v => gridstruct%cosa_v
7819  cosa_s => gridstruct%cosa_s
7820  sina_u => gridstruct%sina_u
7821  sina_v => gridstruct%sina_v
7822  rsin_u => gridstruct%rsin_u
7823  rsin_v => gridstruct%rsin_v
7824  rsina => gridstruct%rsina
7825  f0 => gridstruct%f0
7826  rsin2 => gridstruct%rsin2
7827  divg_u => gridstruct%divg_u
7828  divg_v => gridstruct%divg_v
7829  cosa => gridstruct%cosa
7830  dx => gridstruct%dx
7831  dy => gridstruct%dy
7832  dxc => gridstruct%dxc
7833  dyc => gridstruct%dyc
7834  rdxa => gridstruct%rdxa
7835  rdya => gridstruct%rdya
7836  rdx => gridstruct%rdx
7837  rdy => gridstruct%rdy
7838  sw_corner = gridstruct%sw_corner
7839  se_corner = gridstruct%se_corner
7840  nw_corner = gridstruct%nw_corner
7841  ne_corner = gridstruct%ne_corner
7842  IF (dt .GE. 0.) THEN
7843  absdt = dt
7844  ELSE
7845  absdt = -dt
7846  END IF
7847  da_min = gridstruct%da_min
7848  da_min_c = gridstruct%da_min_c
7849  is = bd%is
7850  ie = bd%ie
7851  js = bd%js
7852  je = bd%je
7853  npx = flagstruct%npx
7854  npy = flagstruct%npy
7855  nested = gridstruct%nested
7856  IF (nested) THEN
7857  is2 = is
7858  ie1 = ie + 1
7859  ELSE
7860  IF (2 .LT. is) THEN
7861  is2 = is
7862  ELSE
7863  is2 = 2
7864  END IF
7865  IF (npx - 1 .GT. ie + 1) THEN
7866  ie1 = ie + 1
7867  ELSE
7868  ie1 = npx - 1
7869  END IF
7870  END IF
7871 !-----------------------------
7872 ! Compute divergence damping
7873 !-----------------------------
7874 ! damp = dddmp * da_min_c
7875  IF (nord .EQ. 0) THEN
7876 ! area ~ dxb*dyb*sin(alpha)
7877  IF (nested) THEN
7878  DO j=js,je+1
7879  DO i=is-1,ie+1
7880  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j))&
7881 & *dyc(i, j)*sina_v(i, j)
7882  END DO
7883  END DO
7884  DO j=js-1,je+1
7885  DO i=is2,ie1
7886  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
7887 & )*dxc(i, j)*sina_u(i, j)
7888  END DO
7889  END DO
7890  ELSE
7891  DO j=js,je+1
7892  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
7893  DO i=is-1,ie+1
7894  IF (vc(i, j) .GT. 0) THEN
7895  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j-1, 4)
7896  ELSE
7897  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j, 2)
7898  END IF
7899  END DO
7900  ELSE
7901  DO i=is-1,ie+1
7902  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j&
7903 & ))*dyc(i, j)*sina_v(i, j)
7904  END DO
7905  END IF
7906  END DO
7907  DO j=js-1,je+1
7908  DO i=is2,ie1
7909  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
7910 & )*dxc(i, j)*sina_u(i, j)
7911  END DO
7912  IF (is .EQ. 1) THEN
7913  IF (uc(1, j) .GT. 0) THEN
7914  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0, j, 3)
7915  ELSE
7916  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1, j, 1)
7917  END IF
7918  END IF
7919  IF (ie + 1 .EQ. npx) THEN
7920  IF (uc(npx, j) .GT. 0) THEN
7921  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx-1, j, 3)
7922  ELSE
7923  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx, j, 1)
7924  END IF
7925  END IF
7926  END DO
7927  END IF
7928  DO j=js,je+1
7929  DO i=is,ie+1
7930  delpc(i, j) = vort(i, j-1) - vort(i, j) + ptc(i-1, j) - ptc(i&
7931 & , j)
7932  END DO
7933  END DO
7934 ! Remove the extra term at the corners:
7935  IF (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
7936  IF (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
7937  IF (ne_corner) delpc(npx, npy) = delpc(npx, npy) + vort(npx, npy)
7938  IF (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
7939  DO j=js,je+1
7940  DO i=is,ie+1
7941  delpc(i, j) = gridstruct%rarea_c(i, j)*delpc(i, j)
7942  IF (delpc(i, j)*dt .GE. 0.) THEN
7943  abs2 = delpc(i, j)*dt
7944  ELSE
7945  abs2 = -(delpc(i, j)*dt)
7946  END IF
7947  y3 = dddmp*abs2
7948  IF (0.20 .GT. y3) THEN
7949  y1 = y3
7950  ELSE
7951  y1 = 0.20
7952  END IF
7953  IF (d2_bg .LT. y1) THEN
7954  max1 = y1
7955  ELSE
7956  max1 = d2_bg
7957  END IF
7958  damp = gridstruct%da_min_c*max1
7959  vort(i, j) = damp*delpc(i, j)
7960  ke(i, j) = ke(i, j) + vort(i, j)
7961  END DO
7962  END DO
7963  ELSE
7964 !--------------------------
7965 ! Higher order divg damping
7966 !--------------------------
7967  DO j=js,je+1
7968  DO i=is,ie+1
7969 ! Save divergence for external mode filter
7970  delpc(i, j) = divg_d(i, j)
7971  END DO
7972  END DO
7973 ! N > 1
7974  n2 = nord + 1
7975  DO n=1,nord
7976  nt = nord - n
7977  fill_c = nt .NE. 0 .AND. flagstruct%grid_type .LT. 3 .AND. (((&
7978 & sw_corner .OR. se_corner) .OR. ne_corner) .OR. nw_corner) &
7979 & .AND. (.NOT.nested)
7980  IF (fill_c) CALL fill_corners(divg_d, npx, npy, fill=xdir, bgrid&
7981 & =.true.)
7982  DO j=js-nt,je+1+nt
7983  DO i=is-1-nt,ie+1+nt
7984  vc(i, j) = (divg_d(i+1, j)-divg_d(i, j))*divg_u(i, j)
7985  END DO
7986  END DO
7987  IF (fill_c) CALL fill_corners(divg_d, npx, npy, fill=ydir, bgrid&
7988 & =.true.)
7989  DO j=js-1-nt,je+1+nt
7990  DO i=is-nt,ie+1+nt
7991  uc(i, j) = (divg_d(i, j+1)-divg_d(i, j))*divg_v(i, j)
7992  END DO
7993  END DO
7994  IF (fill_c) CALL fill_corners(vc, uc, npx, npy, dgrid=.true., &
7995 & vector=.true.)
7996  DO j=js-nt,je+1+nt
7997  DO i=is-nt,ie+1+nt
7998  divg_d(i, j) = uc(i, j-1) - uc(i, j) + vc(i-1, j) - vc(i, j)
7999  END DO
8000  END DO
8001 ! Remove the extra term at the corners:
8002  IF (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
8003  IF (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
8004  IF (ne_corner) divg_d(npx, npy) = divg_d(npx, npy) + uc(npx, npy&
8005 & )
8006  IF (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
8007  IF (.NOT.gridstruct%stretched_grid) THEN
8008  DO j=js-nt,je+1+nt
8009  DO i=is-nt,ie+1+nt
8010  divg_d(i, j) = divg_d(i, j)*gridstruct%rarea_c(i, j)
8011  END DO
8012  END DO
8013  END IF
8014  END DO
8015 ! n-loop
8016  IF (dddmp .LT. 1.e-5) THEN
8017  vort(:, :) = 0.
8018  ELSE IF (flagstruct%grid_type .LT. 3) THEN
8019 ! Interpolate relative vort to cell corners
8020  CALL a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng&
8021 & , .false.)
8022  DO j=js,je+1
8023  DO i=is,ie+1
8024  IF (dt .GE. 0.) THEN
8025  abs0 = dt
8026  ELSE
8027  abs0 = -dt
8028  END IF
8029 ! The following is an approxi form of Smagorinsky diffusion
8030  arg1 = delpc(i, j)**2 + vort(i, j)**2
8031  result1 = sqrt(arg1)
8032  vort(i, j) = abs0*result1
8033  END DO
8034  END DO
8035  ELSE
8036  IF (dt .GE. 0.) THEN
8037  abs1 = dt
8038  ELSE
8039  abs1 = -dt
8040  END IF
8041 ! Correct form: works only for doubly preiodic domain
8042  CALL smag_corner(abs1, u, v, ua, va, vort, bd, npx, npy, &
8043 & gridstruct, ng)
8044  END IF
8045  IF (gridstruct%stretched_grid) THEN
8046 ! Stretched grid with variable damping ~ area
8047  pwr1 = d4_bg**n2
8048  dd8 = gridstruct%da_min*pwr1
8049  ELSE
8050  pwx1 = gridstruct%da_min_c*d4_bg
8051  dd8 = pwx1**n2
8052  END IF
8053  DO j=js,je+1
8054  DO i=is,ie+1
8055  IF (0.20 .GT. dddmp*vort(i, j)) THEN
8056  y2 = dddmp*vort(i, j)
8057  ELSE
8058  y2 = 0.20
8059  END IF
8060  IF (d2_bg .LT. y2) THEN
8061  max2 = y2
8062  ELSE
8063  max2 = d2_bg
8064  END IF
8065 ! del-2
8066  damp2 = gridstruct%da_min_c*max2
8067  vort(i, j) = damp2*delpc(i, j) + dd8*divg_d(i, j)
8068  ke(i, j) = ke(i, j) + vort(i, j)
8069  END DO
8070  END DO
8071  END IF
8072  END SUBROUTINE compute_divergence_damping
8073  SUBROUTINE smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, &
8074 & gridstruct, ng)
8075  IMPLICIT NONE
8076 ! Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion
8077 !!! work only if (grid_type==4)
8078  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8079  REAL, INTENT(IN) :: dt
8080  INTEGER, INTENT(IN) :: npx, npy, ng
8081  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
8082  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
8083  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
8084  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: smag_c
8085  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8086 ! local
8087  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
8088  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
8089 ! work array
8090  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
8091  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
8092  INTEGER :: i, j
8093  INTEGER :: is2, ie1
8094  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
8095  INTEGER :: is, ie, js, je
8096  INTEGER :: isd, ied, jsd, jed
8097  INTRINSIC max
8098  INTRINSIC min
8099  INTRINSIC sqrt
8100  REAL :: arg1
8101  REAL :: result1
8102  is = bd%is
8103  ie = bd%ie
8104  js = bd%js
8105  je = bd%je
8106  isd = bd%isd
8107  ied = bd%ied
8108  jsd = bd%jsd
8109  jed = bd%jed
8110  dxc => gridstruct%dxc
8111  dyc => gridstruct%dyc
8112  dx => gridstruct%dx
8113  dy => gridstruct%dy
8114  rarea => gridstruct%rarea
8115  rarea_c => gridstruct%rarea_c
8116  IF (2 .LT. is) THEN
8117  is2 = is
8118  ELSE
8119  is2 = 2
8120  END IF
8121  IF (npx - 1 .GT. ie + 1) THEN
8122  ie1 = ie + 1
8123  ELSE
8124  ie1 = npx - 1
8125  END IF
8126 ! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s
8127 ! where T = du/dx - dv/dy; S = du/dy + dv/dx
8128 ! Compute tension strain at corners:
8129  DO j=js,je+1
8130  DO i=is-1,ie+1
8131  ut(i, j) = u(i, j)*dyc(i, j)
8132  END DO
8133  END DO
8134  DO j=js-1,je+1
8135  DO i=is,ie+1
8136  vt(i, j) = v(i, j)*dxc(i, j)
8137  END DO
8138  END DO
8139  DO j=js,je+1
8140  DO i=is,ie+1
8141  smag_c(i, j) = rarea_c(i, j)*(vt(i, j-1)-vt(i, j)+(ut(i, j)-ut(i&
8142 & -1, j)))
8143  END DO
8144  END DO
8145 ! Fix the corners?? if grid_type /= 4
8146 ! Compute shear strain:
8147  DO j=jsd,jed+1
8148  DO i=isd,ied
8149  vt(i, j) = u(i, j)*dx(i, j)
8150  END DO
8151  END DO
8152  DO j=jsd,jed
8153  DO i=isd,ied+1
8154  ut(i, j) = v(i, j)*dy(i, j)
8155  END DO
8156  END DO
8157  DO j=jsd,jed
8158  DO i=isd,ied
8159  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i, j)-ut(i+1, j)&
8160 & ))
8161  END DO
8162  END DO
8163  CALL a2b_ord4(wk, sh, gridstruct, npx, npy, is, ie, js, je, ng, &
8164 & .false.)
8165  DO j=js,je+1
8166  DO i=is,ie+1
8167  arg1 = sh(i, j)**2 + smag_c(i, j)**2
8168  result1 = sqrt(arg1)
8169  smag_c(i, j) = dt*result1
8170  END DO
8171  END DO
8172  END SUBROUTINE smag_corner
8173 ! Differentiation of compute_divergence_damping in forward (tangent) mode:
8174 ! variations of useful results: ke uc ptc delpc vc vort divg_d
8175 ! wk
8176 ! with respect to varying inputs: u v ke ua uc ptc delpc va vc
8177 ! divg_d wk
8178  SUBROUTINE compute_divergence_damping_tlm(nord, d2_bg, d4_bg, dddmp&
8179 & , dt, vort, vort_tl, ptc, ptc_tl, delpc, delpc_tl, ke, ke_tl, u, &
8180 & u_tl, v, v_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, divg_d, &
8181 & divg_d_tl, wk, wk_tl, gridstruct, flagstruct, bd)
8182  IMPLICIT NONE
8183 !InOut Arguments
8184  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8185  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8186  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
8187  INTEGER, INTENT(IN) :: nord
8188  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
8189  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
8190  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua_tl, &
8191 & va_tl
8192  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
8193  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u_tl
8194  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
8195  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v_tl
8196 !Intent is really in
8197  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
8198  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
8199 & wk_tl
8200  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
8201  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
8202 & vort_tl
8203  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
8204 & delpc, ptc
8205  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
8206 & delpc_tl, ptc_tl
8207  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
8208 & ke
8209  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
8210 & ke_tl
8211  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
8212  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
8213 & vc_tl
8214  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
8215  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
8216 & uc_tl
8217  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
8218 & divg_d
8219  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
8220 & divg_d_tl
8221 !Locals
8222  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
8223  REAL :: damp_tl, damp2_tl
8224  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
8225  LOGICAL :: nested, fill_c
8226  INTEGER :: i, j, n, n2, nt
8227  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
8228  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
8229  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
8230  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
8231  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
8232  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
8233  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
8234  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
8235 & , rdx, rdy
8236  INTRINSIC ABS
8237  INTRINSIC max
8238  INTRINSIC min
8239  INTRINSIC sqrt
8240  REAL :: max1
8241  REAL :: max1_tl
8242  REAL :: abs0
8243  REAL :: abs1
8244  REAL :: max2
8245  REAL :: max2_tl
8246  REAL :: abs2
8247  REAL :: abs2_tl
8248  REAL :: arg1
8249  REAL :: arg1_tl
8250  REAL :: result1
8251  REAL :: result1_tl
8252  REAL :: pwr1
8253  REAL*8 :: pwx1
8254  REAL :: y3_tl
8255  REAL :: y1_tl
8256  REAL :: y2_tl
8257  REAL :: y3
8258  REAL :: y2
8259  REAL :: y1
8260  area => gridstruct%area
8261  rarea => gridstruct%rarea
8262  sin_sg => gridstruct%sin_sg
8263  cosa_u => gridstruct%cosa_u
8264  cosa_v => gridstruct%cosa_v
8265  cosa_s => gridstruct%cosa_s
8266  sina_u => gridstruct%sina_u
8267  sina_v => gridstruct%sina_v
8268  rsin_u => gridstruct%rsin_u
8269  rsin_v => gridstruct%rsin_v
8270  rsina => gridstruct%rsina
8271  f0 => gridstruct%f0
8272  rsin2 => gridstruct%rsin2
8273  divg_u => gridstruct%divg_u
8274  divg_v => gridstruct%divg_v
8275  cosa => gridstruct%cosa
8276  dx => gridstruct%dx
8277  dy => gridstruct%dy
8278  dxc => gridstruct%dxc
8279  dyc => gridstruct%dyc
8280  rdxa => gridstruct%rdxa
8281  rdya => gridstruct%rdya
8282  rdx => gridstruct%rdx
8283  rdy => gridstruct%rdy
8284  sw_corner = gridstruct%sw_corner
8285  se_corner = gridstruct%se_corner
8286  nw_corner = gridstruct%nw_corner
8287  ne_corner = gridstruct%ne_corner
8288  IF (dt .GE. 0.) THEN
8289  absdt = dt
8290  ELSE
8291  absdt = -dt
8292  END IF
8293  da_min = gridstruct%da_min
8294  da_min_c = gridstruct%da_min_c
8295  is = bd%is
8296  ie = bd%ie
8297  js = bd%js
8298  je = bd%je
8299  npx = flagstruct%npx
8300  npy = flagstruct%npy
8301  nested = gridstruct%nested
8302  IF (nested) THEN
8303  is2 = is
8304  ie1 = ie + 1
8305  ELSE
8306  IF (2 .LT. is) THEN
8307  is2 = is
8308  ELSE
8309  is2 = 2
8310  END IF
8311  IF (npx - 1 .GT. ie + 1) THEN
8312  ie1 = ie + 1
8313  ELSE
8314  ie1 = npx - 1
8315  END IF
8316  END IF
8317 !-----------------------------
8318 ! Compute divergence damping
8319 !-----------------------------
8320 ! damp = dddmp * da_min_c
8321  IF (nord .EQ. 0) THEN
8322 ! area ~ dxb*dyb*sin(alpha)
8323  IF (nested) THEN
8324  DO j=js,je+1
8325  DO i=is-1,ie+1
8326  ptc_tl(i, j) = dyc(i, j)*sina_v(i, j)*(u_tl(i, j)-0.5*cosa_v&
8327 & (i, j)*(va_tl(i, j-1)+va_tl(i, j)))
8328  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j))&
8329 & *dyc(i, j)*sina_v(i, j)
8330  END DO
8331  END DO
8332  vort_tl = 0.0
8333  DO j=js-1,je+1
8334  DO i=is2,ie1
8335  vort_tl(i, j) = dxc(i, j)*sina_u(i, j)*(v_tl(i, j)-0.5*&
8336 & cosa_u(i, j)*(ua_tl(i-1, j)+ua_tl(i, j)))
8337  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
8338 & )*dxc(i, j)*sina_u(i, j)
8339  END DO
8340  END DO
8341  ELSE
8342  DO j=js,je+1
8343  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
8344  DO i=is-1,ie+1
8345  IF (vc(i, j) .GT. 0) THEN
8346  ptc_tl(i, j) = dyc(i, j)*sin_sg(i, j-1, 4)*u_tl(i, j)
8347  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j-1, 4)
8348  ELSE
8349  ptc_tl(i, j) = dyc(i, j)*sin_sg(i, j, 2)*u_tl(i, j)
8350  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j, 2)
8351  END IF
8352  END DO
8353  ELSE
8354  DO i=is-1,ie+1
8355  ptc_tl(i, j) = dyc(i, j)*sina_v(i, j)*(u_tl(i, j)-0.5*&
8356 & cosa_v(i, j)*(va_tl(i, j-1)+va_tl(i, j)))
8357  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j&
8358 & ))*dyc(i, j)*sina_v(i, j)
8359  END DO
8360  END IF
8361  END DO
8362  vort_tl = 0.0
8363  DO j=js-1,je+1
8364  DO i=is2,ie1
8365  vort_tl(i, j) = dxc(i, j)*sina_u(i, j)*(v_tl(i, j)-0.5*&
8366 & cosa_u(i, j)*(ua_tl(i-1, j)+ua_tl(i, j)))
8367  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
8368 & )*dxc(i, j)*sina_u(i, j)
8369  END DO
8370  IF (is .EQ. 1) THEN
8371  IF (uc(1, j) .GT. 0) THEN
8372  vort_tl(1, j) = dxc(1, j)*sin_sg(0, j, 3)*v_tl(1, j)
8373  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0, j, 3)
8374  ELSE
8375  vort_tl(1, j) = dxc(1, j)*sin_sg(1, j, 1)*v_tl(1, j)
8376  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1, j, 1)
8377  END IF
8378  END IF
8379  IF (ie + 1 .EQ. npx) THEN
8380  IF (uc(npx, j) .GT. 0) THEN
8381  vort_tl(npx, j) = dxc(npx, j)*sin_sg(npx-1, j, 3)*v_tl(npx&
8382 & , j)
8383  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx-1, j, 3)
8384  ELSE
8385  vort_tl(npx, j) = dxc(npx, j)*sin_sg(npx, j, 1)*v_tl(npx, &
8386 & j)
8387  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx, j, 1)
8388  END IF
8389  END IF
8390  END DO
8391  END IF
8392  DO j=js,je+1
8393  DO i=is,ie+1
8394  delpc_tl(i, j) = vort_tl(i, j-1) - vort_tl(i, j) + ptc_tl(i-1&
8395 & , j) - ptc_tl(i, j)
8396  delpc(i, j) = vort(i, j-1) - vort(i, j) + (ptc(i-1, j)-ptc(i, &
8397 & j))
8398  END DO
8399  END DO
8400 ! Remove the extra term at the corners:
8401  IF (sw_corner) THEN
8402  delpc_tl(1, 1) = delpc_tl(1, 1) - vort_tl(1, 0)
8403  delpc(1, 1) = delpc(1, 1) - vort(1, 0)
8404  END IF
8405  IF (se_corner) THEN
8406  delpc_tl(npx, 1) = delpc_tl(npx, 1) - vort_tl(npx, 0)
8407  delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
8408  END IF
8409  IF (ne_corner) THEN
8410  delpc_tl(npx, npy) = delpc_tl(npx, npy) + vort_tl(npx, npy)
8411  delpc(npx, npy) = delpc(npx, npy) + vort(npx, npy)
8412  END IF
8413  IF (nw_corner) THEN
8414  delpc_tl(1, npy) = delpc_tl(1, npy) + vort_tl(1, npy)
8415  delpc(1, npy) = delpc(1, npy) + vort(1, npy)
8416  END IF
8417  DO j=js,je+1
8418  DO i=is,ie+1
8419  delpc_tl(i, j) = gridstruct%rarea_c(i, j)*delpc_tl(i, j)
8420  delpc(i, j) = gridstruct%rarea_c(i, j)*delpc(i, j)
8421  IF (delpc(i, j)*dt .GE. 0.) THEN
8422  abs2_tl = dt*delpc_tl(i, j)
8423  abs2 = delpc(i, j)*dt
8424  ELSE
8425  abs2_tl = -(dt*delpc_tl(i, j))
8426  abs2 = -(delpc(i, j)*dt)
8427  END IF
8428  y3_tl = dddmp*abs2_tl
8429  y3 = dddmp*abs2
8430  IF (0.20 .GT. y3) THEN
8431  y1_tl = y3_tl
8432  y1 = y3
8433  ELSE
8434  y1 = 0.20
8435  y1_tl = 0.0
8436  END IF
8437  IF (d2_bg .LT. y1) THEN
8438  max1_tl = y1_tl
8439  max1 = y1
8440  ELSE
8441  max1 = d2_bg
8442  max1_tl = 0.0
8443  END IF
8444  damp_tl = gridstruct%da_min_c*max1_tl
8445  damp = gridstruct%da_min_c*max1
8446  vort_tl(i, j) = damp_tl*delpc(i, j) + damp*delpc_tl(i, j)
8447  vort(i, j) = damp*delpc(i, j)
8448  ke_tl(i, j) = ke_tl(i, j) + vort_tl(i, j)
8449  ke(i, j) = ke(i, j) + vort(i, j)
8450  END DO
8451  END DO
8452  ELSE
8453 !--------------------------
8454 ! Higher order divg damping
8455 !--------------------------
8456  DO j=js,je+1
8457  DO i=is,ie+1
8458 ! Save divergence for external mode filter
8459  delpc_tl(i, j) = divg_d_tl(i, j)
8460  delpc(i, j) = divg_d(i, j)
8461  END DO
8462  END DO
8463 ! N > 1
8464  n2 = nord + 1
8465  DO n=1,nord
8466  nt = nord - n
8467  fill_c = nt .NE. 0 .AND. flagstruct%grid_type .LT. 3 .AND. (((&
8468 & sw_corner .OR. se_corner) .OR. ne_corner) .OR. nw_corner) &
8469 & .AND. (.NOT.nested)
8470  IF (fill_c) CALL fill_corners_tlm(divg_d, divg_d_tl, npx, npy, &
8471 & fill=xdir, bgrid=.true.)
8472  DO j=js-nt,je+1+nt
8473  DO i=is-1-nt,ie+1+nt
8474  vc_tl(i, j) = divg_u(i, j)*(divg_d_tl(i+1, j)-divg_d_tl(i, j&
8475 & ))
8476  vc(i, j) = (divg_d(i+1, j)-divg_d(i, j))*divg_u(i, j)
8477  END DO
8478  END DO
8479  IF (fill_c) CALL fill_corners_tlm(divg_d, divg_d_tl, npx, npy, &
8480 & fill=ydir, bgrid=.true.)
8481  DO j=js-1-nt,je+1+nt
8482  DO i=is-nt,ie+1+nt
8483  uc_tl(i, j) = divg_v(i, j)*(divg_d_tl(i, j+1)-divg_d_tl(i, j&
8484 & ))
8485  uc(i, j) = (divg_d(i, j+1)-divg_d(i, j))*divg_v(i, j)
8486  END DO
8487  END DO
8488  IF (fill_c) CALL fill_corners_tlm(vc, vc_tl, uc, uc_tl, npx, npy&
8489 & , dgrid=.true., vector=.true.)
8490  DO j=js-nt,je+1+nt
8491  DO i=is-nt,ie+1+nt
8492  divg_d_tl(i, j) = uc_tl(i, j-1) - uc_tl(i, j) + vc_tl(i-1, j&
8493 & ) - vc_tl(i, j)
8494  divg_d(i, j) = uc(i, j-1) - uc(i, j) + (vc(i-1, j)-vc(i, j))
8495  END DO
8496  END DO
8497 ! Remove the extra term at the corners:
8498  IF (sw_corner) THEN
8499  divg_d_tl(1, 1) = divg_d_tl(1, 1) - uc_tl(1, 0)
8500  divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
8501  END IF
8502  IF (se_corner) THEN
8503  divg_d_tl(npx, 1) = divg_d_tl(npx, 1) - uc_tl(npx, 0)
8504  divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
8505  END IF
8506  IF (ne_corner) THEN
8507  divg_d_tl(npx, npy) = divg_d_tl(npx, npy) + uc_tl(npx, npy)
8508  divg_d(npx, npy) = divg_d(npx, npy) + uc(npx, npy)
8509  END IF
8510  IF (nw_corner) THEN
8511  divg_d_tl(1, npy) = divg_d_tl(1, npy) + uc_tl(1, npy)
8512  divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
8513  END IF
8514  IF (.NOT.gridstruct%stretched_grid) THEN
8515  DO j=js-nt,je+1+nt
8516  DO i=is-nt,ie+1+nt
8517  divg_d_tl(i, j) = gridstruct%rarea_c(i, j)*divg_d_tl(i, j)
8518  divg_d(i, j) = divg_d(i, j)*gridstruct%rarea_c(i, j)
8519  END DO
8520  END DO
8521  END IF
8522  END DO
8523 ! n-loop
8524  IF (dddmp .LT. 1.e-5) THEN
8525  vort(:, :) = 0.
8526  vort_tl = 0.0
8527  ELSE IF (flagstruct%grid_type .LT. 3) THEN
8528 ! Interpolate relative vort to cell corners
8529  vort_tl = 0.0
8530  CALL a2b_ord4_tlm(wk, wk_tl, vort, vort_tl, gridstruct, npx, &
8531 & npy, is, ie, js, je, ng, .false.)
8532  DO j=js,je+1
8533  DO i=is,ie+1
8534  IF (dt .GE. 0.) THEN
8535  abs0 = dt
8536  ELSE
8537  abs0 = -dt
8538  END IF
8539 ! The following is an approxi form of Smagorinsky diffusion
8540  arg1_tl = 2*delpc(i, j)*delpc_tl(i, j) + 2*vort(i, j)*&
8541 & vort_tl(i, j)
8542  arg1 = delpc(i, j)**2 + vort(i, j)**2
8543  IF (arg1 .EQ. 0.0) THEN
8544  result1_tl = 0.0
8545  ELSE
8546  result1_tl = arg1_tl/(2.0*sqrt(arg1))
8547  END IF
8548  result1 = sqrt(arg1)
8549  vort_tl(i, j) = abs0*result1_tl
8550  vort(i, j) = abs0*result1
8551  END DO
8552  END DO
8553  ELSE
8554  IF (dt .GE. 0.) THEN
8555  abs1 = dt
8556  ELSE
8557  abs1 = -dt
8558  END IF
8559 ! Correct form: works only for doubly preiodic domain
8560  CALL smag_corner_tlm(abs1, u, u_tl, v, v_tl, ua, va, vort, &
8561 & vort_tl, bd, npx, npy, gridstruct, ng)
8562  END IF
8563  IF (gridstruct%stretched_grid) THEN
8564 ! Stretched grid with variable damping ~ area
8565  pwr1 = d4_bg**n2
8566  dd8 = gridstruct%da_min*pwr1
8567  ELSE
8568  pwx1 = gridstruct%da_min_c*d4_bg
8569  dd8 = pwx1**n2
8570  END IF
8571  DO j=js,je+1
8572  DO i=is,ie+1
8573  IF (0.20 .GT. dddmp*vort(i, j)) THEN
8574  y2_tl = dddmp*vort_tl(i, j)
8575  y2 = dddmp*vort(i, j)
8576  ELSE
8577  y2 = 0.20
8578  y2_tl = 0.0
8579  END IF
8580  IF (d2_bg .LT. y2) THEN
8581  max2_tl = y2_tl
8582  max2 = y2
8583  ELSE
8584  max2 = d2_bg
8585  max2_tl = 0.0
8586  END IF
8587 ! del-2
8588  damp2_tl = gridstruct%da_min_c*max2_tl
8589  damp2 = gridstruct%da_min_c*max2
8590  vort_tl(i, j) = damp2_tl*delpc(i, j) + damp2*delpc_tl(i, j) + &
8591 & dd8*divg_d_tl(i, j)
8592  vort(i, j) = damp2*delpc(i, j) + dd8*divg_d(i, j)
8593  ke_tl(i, j) = ke_tl(i, j) + vort_tl(i, j)
8594  ke(i, j) = ke(i, j) + vort(i, j)
8595  END DO
8596  END DO
8597  END IF
8598  END SUBROUTINE compute_divergence_damping_tlm
8599 ! Differentiation of smag_corner in forward (tangent) mode:
8600 ! variations of useful results: smag_c
8601 ! with respect to varying inputs: u v
8602  SUBROUTINE smag_corner_tlm(dt, u, u_tl, v, v_tl, ua, va, smag_c, &
8603 & smag_c_tl, bd, npx, npy, gridstruct, ng)
8604  IMPLICIT NONE
8605 ! Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion
8606 !!! work only if (grid_type==4)
8607  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8608  REAL, INTENT(IN) :: dt
8609  INTEGER, INTENT(IN) :: npx, npy, ng
8610  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
8611  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u_tl
8612  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
8613  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v_tl
8614  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
8615  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: smag_c
8616  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: &
8617 & smag_c_tl
8618  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8619 ! local
8620  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
8621  REAL :: ut_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed)
8622  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
8623  REAL :: vt_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1)
8624 ! work array
8625  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
8626  REAL :: wk_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
8627  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
8628  REAL :: sh_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
8629  INTEGER :: i, j
8630  INTEGER :: is2, ie1
8631  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
8632  INTEGER :: is, ie, js, je
8633  INTEGER :: isd, ied, jsd, jed
8634  INTRINSIC max
8635  INTRINSIC min
8636  INTRINSIC sqrt
8637  REAL :: arg1
8638  REAL :: arg1_tl
8639  REAL :: result1
8640  REAL :: result1_tl
8641  is = bd%is
8642  ie = bd%ie
8643  js = bd%js
8644  je = bd%je
8645  isd = bd%isd
8646  ied = bd%ied
8647  jsd = bd%jsd
8648  jed = bd%jed
8649  dxc => gridstruct%dxc
8650  dyc => gridstruct%dyc
8651  dx => gridstruct%dx
8652  dy => gridstruct%dy
8653  rarea => gridstruct%rarea
8654  rarea_c => gridstruct%rarea_c
8655  IF (2 .LT. is) THEN
8656  is2 = is
8657  ELSE
8658  is2 = 2
8659  END IF
8660  IF (npx - 1 .GT. ie + 1) THEN
8661  ie1 = ie + 1
8662  ELSE
8663  ie1 = npx - 1
8664  END IF
8665  ut_tl = 0.0
8666 ! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s
8667 ! where T = du/dx - dv/dy; S = du/dy + dv/dx
8668 ! Compute tension strain at corners:
8669  DO j=js,je+1
8670  DO i=is-1,ie+1
8671  ut_tl(i, j) = dyc(i, j)*u_tl(i, j)
8672  ut(i, j) = u(i, j)*dyc(i, j)
8673  END DO
8674  END DO
8675  vt_tl = 0.0
8676  DO j=js-1,je+1
8677  DO i=is,ie+1
8678  vt_tl(i, j) = dxc(i, j)*v_tl(i, j)
8679  vt(i, j) = v(i, j)*dxc(i, j)
8680  END DO
8681  END DO
8682  smag_c_tl = 0.0
8683  DO j=js,je+1
8684  DO i=is,ie+1
8685  smag_c_tl(i, j) = rarea_c(i, j)*(vt_tl(i, j-1)-vt_tl(i, j)-ut_tl&
8686 & (i-1, j)+ut_tl(i, j))
8687  smag_c(i, j) = rarea_c(i, j)*(vt(i, j-1)-vt(i, j)-ut(i-1, j)+ut(&
8688 & i, j))
8689  END DO
8690  END DO
8691 ! Fix the corners?? if grid_type /= 4
8692 ! Compute shear strain:
8693  DO j=jsd,jed+1
8694  DO i=isd,ied
8695  vt_tl(i, j) = dx(i, j)*u_tl(i, j)
8696  vt(i, j) = u(i, j)*dx(i, j)
8697  END DO
8698  END DO
8699  DO j=jsd,jed
8700  DO i=isd,ied+1
8701  ut_tl(i, j) = dy(i, j)*v_tl(i, j)
8702  ut(i, j) = v(i, j)*dy(i, j)
8703  END DO
8704  END DO
8705  wk_tl = 0.0
8706  DO j=jsd,jed
8707  DO i=isd,ied
8708  wk_tl(i, j) = rarea(i, j)*(vt_tl(i, j)-vt_tl(i, j+1)+ut_tl(i, j)&
8709 & -ut_tl(i+1, j))
8710  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+ut(i, j)-ut(i+1, j))
8711  END DO
8712  END DO
8713  sh_tl = 0.0
8714  CALL a2b_ord4_tlm(wk, wk_tl, sh, sh_tl, gridstruct, npx, npy, is&
8715 & , ie, js, je, ng, .false.)
8716  DO j=js,je+1
8717  DO i=is,ie+1
8718  arg1_tl = 2*sh(i, j)*sh_tl(i, j) + 2*smag_c(i, j)*smag_c_tl(i, j&
8719 & )
8720  arg1 = sh(i, j)**2 + smag_c(i, j)**2
8721  IF (arg1 .EQ. 0.0) THEN
8722  result1_tl = 0.0
8723  ELSE
8724  result1_tl = arg1_tl/(2.0*sqrt(arg1))
8725  END IF
8726  result1 = sqrt(arg1)
8727  smag_c_tl(i, j) = dt*result1_tl
8728  smag_c(i, j) = dt*result1
8729  END DO
8730  END DO
8731  END SUBROUTINE smag_corner_tlm
8732  end module sw_core_tlm_mod
sw_core_tlm_mod::xtp_u_tlm
subroutine xtp_u_tlm(is, ie, js, je, isd, ied, jsd, jed, c, c_tl, u, u_tl, v, flux, flux_tl, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_tlm.F90:7275
sw_core_tlm_mod::divergence_corner_tlm
subroutine, public divergence_corner_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, va_tl, divg_d, divg_d_tl, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:3807
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
sw_core_tlm_mod::s11
real, parameter s11
Definition: sw_core_tlm.F90:41
sw_core_tlm_mod::r3
real, parameter r3
Definition: sw_core_tlm.F90:39
sw_core_tlm_mod::xtp_u
subroutine xtp_u(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_tlm.F90:4312
a2b_edge_tlm_mod
Definition: a2b_edge_tlm.F90:20
tp_core_tlm_mod::fv_tp_2d_tlm
subroutine, public fv_tp_2d_tlm(q, q_tl, crx, crx_tl, cry, cry_tl, npx, npy, hord, fx, fx_tl, fy, fy_tl, xfx, xfx_tl, yfx, yfx_tl, gridstruct, bd, ra_x, ra_x_tl, ra_y, ra_y_tl, mfx, mfx_tl, mfy, mfy_tl, mass, mass_tl, nord, damp_c)
Definition: tp_core_tlm.F90:2127
sw_core_tlm_mod::d2a2c_vect_tlm
subroutine, public d2a2c_vect_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, va_tl, uc, uc_tl, vc, vc_tl, ut, ut_tl, vt, vt_tl, dord4, gridstruct, bd, npx, npy, nested, grid_type)
Definition: sw_core_tlm.F90:5877
fv_mp_tlm_mod
Definition: fv_mp_tlm.F90:20
sw_core_tlm_mod::s15
real, parameter s15
Definition: sw_core_tlm.F90:41
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
qg_constants::f0
real(kind=kind_real), parameter f0
Coriolis parameter at southern boundary.
Definition: qg_constants.f90:26
sw_core_tlm_mod::fill_4corners_tlm
subroutine, public fill_4corners_tlm(q, q_tl, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_tlm.F90:7140
sw_core_tlm_mod::t14
real, parameter t14
Definition: sw_core_tlm.F90:40
sw_core_tlm_mod::t11
real, parameter t11
Definition: sw_core_tlm.F90:40
a2b_edge_tlm_mod::a2b_ord4
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_tlm.F90:50
sw_core_tlm_mod::divergence_corner_nest
subroutine, public divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:4213
sw_core_tlm_mod::b4
real, parameter b4
Definition: sw_core_tlm.F90:72
sw_core_tlm_mod::c3
real, parameter c3
Definition: sw_core_tlm.F90:62
sw_core_tlm_mod::s13
real, parameter s13
Definition: sw_core_tlm.F90:41
sw_core_tlm_mod::b1
real, parameter b1
Definition: sw_core_tlm.F90:69
sw_core_tlm_mod::fill_4corners
subroutine, public fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_tlm.F90:7214
fv_mp_tlm_mod::fill_corners_tlm
Definition: fv_mp_tlm.F90:72
sw_core_tlm_mod::b2
real, parameter b2
Definition: sw_core_tlm.F90:70
sw_core_tlm_mod::ytp_v
subroutine ytp_v(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_tlm.F90:5045
tp_core_tlm_mod
Definition: tp_core_tlm.F90:20
sw_core_tlm_mod::smag_corner
subroutine smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, gridstruct, ng)
Definition: sw_core_tlm.F90:8075
tp_core_tlm_mod::pert_ppm
subroutine, public pert_ppm(im, a0, al, ar, iv)
Definition: tp_core_tlm.F90:1854
sw_core_tlm_mod::a1
real, parameter a1
Definition: sw_core_tlm.F90:56
sw_core_tlm_mod::d_sw
subroutine, public d_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_tlm.F90:2542
sw_core_tlm_mod::fill2_4corners
subroutine fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_tlm.F90:7063
sw_core_tlm_mod::t12
real, parameter t12
Definition: sw_core_tlm.F90:40
sw_core_tlm_mod::d2a2c_vect
subroutine, public d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd, npx, npy, nested, grid_type)
Definition: sw_core_tlm.F90:6401
sw_core_tlm_mod::compute_divergence_damping
subroutine compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:7763
sw_core_tlm_mod::t13
real, parameter t13
Definition: sw_core_tlm.F90:40
sw_core_tlm_mod::near_zero
real, parameter near_zero
Definition: sw_core_tlm.F90:42
sw_core_tlm_mod::divergence_corner_nest_tlm
subroutine, public divergence_corner_nest_tlm(u, u_tl, v, v_tl, ua, ua_tl, va, va_tl, divg_d, divg_d_tl, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:4088
sw_core_tlm_mod::c2
real, parameter c2
Definition: sw_core_tlm.F90:61
fv_mp_nlm_mod::ng
integer, parameter, public ng
Definition: fv_mp_nlm_mod.F90:2465
sw_core_tlm_mod::c_sw_tlm
subroutine, public c_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, wc, wc_tl, ut, ut_tl, vt, vt_tl, divg_d, divg_d_tl, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_tlm.F90:91
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
sw_core_tlm_mod::fill3_4corners
subroutine fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_tlm.F90:6836
sw_core_tlm_mod::p2
real, parameter p2
Definition: sw_core_tlm.F90:52
tp_core_tlm_mod::copy_corners
subroutine, public copy_corners(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_tlm.F90:2048
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
fv_arrays_tlmadm_mod::fpp
type(fpp_type) fpp
Definition: fv_arrays_tlmadm.F90:35
sw_core_tlm_mod
Definition: sw_core_tlm.F90:20
sw_core_tlm_mod::p1
real, parameter p1
Definition: sw_core_tlm.F90:51
test_cases_nlm_mod
Definition: test_cases_nlm.F90:21
sw_core_tlm_mod::edge_interpolate4_tlm
real function edge_interpolate4_tlm(ua, ua_tl, dxa, edge_interpolate4)
Definition: sw_core_tlm.F90:6811
sw_core_tlm_mod::compute_divergence_damping_tlm
subroutine compute_divergence_damping_tlm(nord, d2_bg, d4_bg, dddmp, dt, vort, vort_tl, ptc, ptc_tl, delpc, delpc_tl, ke, ke_tl, u, u_tl, v, v_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, divg_d, divg_d_tl, wk, wk_tl, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:8182
sw_core_tlm_mod::b3
real, parameter b3
Definition: sw_core_tlm.F90:71
sw_core_tlm_mod::del6_vt_flux_tlm
subroutine, public del6_vt_flux_tlm(nord, npx, npy, damp, q, q_tl, d2, d2_tl, fx2, fx2_tl, fy2, fy2_tl, gridstruct, bd)
Definition: sw_core_tlm.F90:3623
a2b_edge_tlm_mod::a2b_ord4_tlm
subroutine, public a2b_ord4_tlm(qin, qin_tl, qout, qout_tl, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_tlm.F90:548
max
#define max(a, b)
Definition: mosaic_util.h:33
sw_core_tlm_mod::t15
real, parameter t15
Definition: sw_core_tlm.F90:40
sw_core_tlm_mod::big_number
real, parameter big_number
Definition: sw_core_tlm.F90:46
sw_core_tlm_mod::b5
real, parameter b5
Definition: sw_core_tlm.F90:73
sw_core_tlm_mod::smag_corner_tlm
subroutine smag_corner_tlm(dt, u, u_tl, v, v_tl, ua, va, smag_c, smag_c_tl, bd, npx, npy, gridstruct, ng)
Definition: sw_core_tlm.F90:8604
test_cases_nlm_mod::test_case
integer, public test_case
Definition: test_cases_nlm.F90:96
sw_core_tlm_mod::ytp_v_tlm
subroutine ytp_v_tlm(is, ie, js, je, isd, ied, jsd, jed, c, c_tl, u, v, v_tl, flux, flux_tl, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_tlm.F90:7493
tp_core_tlm_mod::fv_tp_2d
subroutine, public fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
Definition: tp_core_tlm.F90:85
sw_core_tlm_mod::s14
real, parameter s14
Definition: sw_core_tlm.F90:41
sw_core_tlm_mod::del6_vt_flux
subroutine, public del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, gridstruct, bd)
Definition: sw_core_tlm.F90:3721
sw_core_tlm_mod::c1
real, parameter c1
Definition: sw_core_tlm.F90:60
sw_core_tlm_mod::c_sw
subroutine, public c_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_tlm.F90:649
min
#define min(a, b)
Definition: mosaic_util.h:32
sw_core_tlm_mod::d_sw_tlm
subroutine, public d_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, divg_d, divg_d_tl, xflux, xflux_tl, yflux, yflux_tl, cx, cx_tl, cy, cy_tl, crx_adv, crx_adv_tl, cry_adv, cry_adv_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, q_con, z_rat, z_rat_tl, kgb, heat_source, heat_source_tl, dpx, dpx_tl, zvir, sphum, nq, q, q_tl, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_tlm.F90:1059
tp_core_tlm_mod::copy_corners_tlm
subroutine, public copy_corners_tlm(q, q_tl, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_tlm.F90:2845
sw_core_tlm_mod::edge_interpolate4
real function edge_interpolate4(ua, dxa)
Definition: sw_core_tlm.F90:6825
sw_core_tlm_mod::divergence_corner
subroutine, public divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_tlm.F90:3968
sw_core_tlm_mod::a2
real, parameter a2
Definition: sw_core_tlm.F90:57
sw_core_tlm_mod::fill2_4corners_tlm
subroutine fill2_4corners_tlm(q1, q1_tl, q2, q2_tl, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_tlm.F90:6955
fv_arrays_nlm_mod::fv_grid_bounds_type
Definition: fv_arrays_nlm.F90:601
unstructured_grid_mod::grid_type
Derived type containing the data.
Definition: unstructured_grid_mod.F90:23
qg_constants::u2
real(kind=kind_real), parameter u2
Definition: qg_constants.f90:36