1 | MODULE traadv_tvd |
---|
2 | !!============================================================================== |
---|
3 | !! *** MODULE traadv_tvd *** |
---|
4 | !! Ocean tracers: horizontal & vertical advective trend |
---|
5 | !!============================================================================== |
---|
6 | !! History : OPA ! 1995-12 (L. Mortier) Original code |
---|
7 | !! ! 2000-01 (H. Loukos) adapted to ORCA |
---|
8 | !! ! 2000-10 (MA Foujols E.Kestenare) include file not routine |
---|
9 | !! ! 2000-12 (E. Kestenare M. Levy) fix bug in trtrd indexes |
---|
10 | !! ! 2001-07 (E. Durand G. Madec) adaptation to ORCA config |
---|
11 | !! 8.5 ! 2002-06 (G. Madec) F90: Free form and module |
---|
12 | !! NEMO 1.0 ! 2004-01 (A. de Miranda, G. Madec, J.M. Molines ): advective bbl |
---|
13 | !! 2.0 ! 2008-04 (S. Cravatte) add the i-, j- & k- trends computation |
---|
14 | !! - ! 2009-11 (V. Garnier) Surface pressure gradient organization |
---|
15 | !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport |
---|
16 | !!---------------------------------------------------------------------- |
---|
17 | |
---|
18 | !!---------------------------------------------------------------------- |
---|
19 | !! tra_adv_tvd : update the tracer trend with the 3D advection trends using a TVD scheme |
---|
20 | !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm |
---|
21 | !!---------------------------------------------------------------------- |
---|
22 | USE oce ! ocean dynamics and active tracers |
---|
23 | USE dom_oce ! ocean space and time domain |
---|
24 | USE trc_oce ! share passive tracers/Ocean variables |
---|
25 | USE trd_oce ! trends: ocean variables |
---|
26 | USE trdtra ! tracers trends |
---|
27 | USE dynspg_oce ! choice/control of key cpp for surface pressure gradient |
---|
28 | USE diaptr ! poleward transport diagnostics |
---|
29 | ! |
---|
30 | USE lib_mpp ! MPP library |
---|
31 | USE lbclnk ! ocean lateral boundary condition (or mpp link) |
---|
32 | USE in_out_manager ! I/O manager |
---|
33 | USE wrk_nemo ! Memory Allocation |
---|
34 | USE timing ! Timing |
---|
35 | USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) |
---|
36 | |
---|
37 | IMPLICIT NONE |
---|
38 | PRIVATE |
---|
39 | |
---|
40 | PUBLIC tra_adv_tvd ! routine called by traadv.F90 |
---|
41 | PUBLIC tra_adv_tvd_zts ! routine called by traadv.F90 |
---|
42 | |
---|
43 | LOGICAL :: l_trd ! flag to compute trends |
---|
44 | |
---|
45 | !! * Substitutions |
---|
46 | # include "domzgr_substitute.h90" |
---|
47 | # include "vectopt_loop_substitute.h90" |
---|
48 | !!---------------------------------------------------------------------- |
---|
49 | !! NEMO/OPA 3.3 , NEMO Consortium (2010) |
---|
50 | !! $Id$ |
---|
51 | !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) |
---|
52 | !!---------------------------------------------------------------------- |
---|
53 | CONTAINS |
---|
54 | |
---|
55 | SUBROUTINE tra_adv_tvd ( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & |
---|
56 | & ptb, ptn, pta, kjpt ) |
---|
57 | !!---------------------------------------------------------------------- |
---|
58 | !! *** ROUTINE tra_adv_tvd *** |
---|
59 | !! |
---|
60 | !! ** Purpose : Compute the now trend due to total advection of |
---|
61 | !! tracers and add it to the general trend of tracer equations |
---|
62 | !! |
---|
63 | !! ** Method : TVD scheme, i.e. 2nd order centered scheme with |
---|
64 | !! corrected flux (monotonic correction) |
---|
65 | !! note: - this advection scheme needs a leap-frog time scheme |
---|
66 | !! |
---|
67 | !! ** Action : - update (pta) with the now advective tracer trends |
---|
68 | !! - save the trends |
---|
69 | !!---------------------------------------------------------------------- |
---|
70 | USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace |
---|
71 | ! |
---|
72 | INTEGER , INTENT(in ) :: kt ! ocean time-step index |
---|
73 | INTEGER , INTENT(in ) :: kit000 ! first time step index |
---|
74 | CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) |
---|
75 | INTEGER , INTENT(in ) :: kjpt ! number of tracers |
---|
76 | REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt ! vertical profile of tracer time-step |
---|
77 | REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components |
---|
78 | REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields |
---|
79 | REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend |
---|
80 | ! |
---|
81 | INTEGER :: ji, jj, jk, jn ! dummy loop indices |
---|
82 | INTEGER :: ik |
---|
83 | REAL(wp) :: z2dtt, zbtr, ztra ! local scalar |
---|
84 | REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - - |
---|
85 | REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - - |
---|
86 | REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz |
---|
87 | REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz |
---|
88 | !!---------------------------------------------------------------------- |
---|
89 | ! |
---|
90 | IF( nn_timing == 1 ) CALL timing_start('tra_adv_tvd') |
---|
91 | ! |
---|
92 | CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz ) |
---|
93 | ! |
---|
94 | IF( kt == kit000 ) THEN |
---|
95 | IF(lwp) WRITE(numout,*) |
---|
96 | IF(lwp) WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme on ', cdtype |
---|
97 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' |
---|
98 | ! |
---|
99 | l_trd = .FALSE. |
---|
100 | IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. |
---|
101 | ENDIF |
---|
102 | ! |
---|
103 | IF( l_trd ) THEN |
---|
104 | CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) |
---|
105 | !$OMP PARALLEL WORKSHARE |
---|
106 | ztrdx(:,:,:) = 0.e0 ; ztrdy(:,:,:) = 0.e0 ; ztrdz(:,:,:) = 0.e0 |
---|
107 | !$OMP END PARALLEL WORKSHARE |
---|
108 | ENDIF |
---|
109 | ! |
---|
110 | !$OMP PARALLEL WORKSHARE |
---|
111 | zwi(:,:,:) = 0.e0 ; |
---|
112 | !$OMP END PARALLEL WORKSHARE |
---|
113 | ! |
---|
114 | ! ! =========== |
---|
115 | DO jn = 1, kjpt ! tracer loop |
---|
116 | ! ! =========== |
---|
117 | ! 1. Bottom and k=1 value : flux set to zero |
---|
118 | ! ---------------------------------- |
---|
119 | zwx(:,:,jpk) = 0.e0 ; zwz(:,:,jpk) = 0.e0 |
---|
120 | zwy(:,:,jpk) = 0.e0 ; zwi(:,:,jpk) = 0.e0 |
---|
121 | |
---|
122 | zwz(:,:,1 ) = 0._wp |
---|
123 | ! 2. upstream advection with initial mass fluxes & intermediate update |
---|
124 | ! -------------------------------------------------------------------- |
---|
125 | ! upstream tracer flux in the i and j direction |
---|
126 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zfp_vj, zfm_vj, zfp_ui, zfm_ui) |
---|
127 | DO jk = 1, jpkm1 |
---|
128 | DO jj = 1, jpjm1 |
---|
129 | DO ji = 1, fs_jpim1 ! vector opt. |
---|
130 | ! upstream scheme |
---|
131 | zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) |
---|
132 | zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) |
---|
133 | zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) |
---|
134 | zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) |
---|
135 | zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) ) |
---|
136 | zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) ) |
---|
137 | END DO |
---|
138 | END DO |
---|
139 | END DO |
---|
140 | |
---|
141 | ! upstream tracer flux in the k direction |
---|
142 | ! Interior value |
---|
143 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zfp_wk, zfm_wk) |
---|
144 | DO jk = 2, jpkm1 |
---|
145 | DO jj = 1, jpj |
---|
146 | DO ji = 1, jpi |
---|
147 | zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) |
---|
148 | zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) |
---|
149 | zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) |
---|
150 | END DO |
---|
151 | END DO |
---|
152 | END DO |
---|
153 | ! Surface value |
---|
154 | IF( lk_vvl ) THEN |
---|
155 | IF ( ln_isfcav ) THEN |
---|
156 | DO jj = 1, jpj |
---|
157 | DO ji = 1, jpi |
---|
158 | zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable |
---|
159 | END DO |
---|
160 | END DO |
---|
161 | ELSE |
---|
162 | zwz(:,:,1) = 0.e0 ! volume variable |
---|
163 | END IF |
---|
164 | ELSE |
---|
165 | IF ( ln_isfcav ) THEN |
---|
166 | DO jj = 1, jpj |
---|
167 | DO ji = 1, jpi |
---|
168 | zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface |
---|
169 | END DO |
---|
170 | END DO |
---|
171 | ELSE |
---|
172 | zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface |
---|
173 | END IF |
---|
174 | ENDIF |
---|
175 | |
---|
176 | ! total advective trend |
---|
177 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zbtr, ztra) |
---|
178 | DO jk = 1, jpkm1 |
---|
179 | z2dtt = p2dt(jk) |
---|
180 | DO jj = 2, jpjm1 |
---|
181 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
182 | zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) |
---|
183 | ! total intermediate advective trends |
---|
184 | ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & |
---|
185 | & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & |
---|
186 | & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) |
---|
187 | ! update and guess with monotonic sheme |
---|
188 | pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) |
---|
189 | zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) |
---|
190 | END DO |
---|
191 | END DO |
---|
192 | END DO |
---|
193 | ! ! Lateral boundary conditions on zwi (unchanged sign) |
---|
194 | CALL lbc_lnk( zwi, 'T', 1. ) |
---|
195 | |
---|
196 | ! ! trend diagnostics (contribution of upstream fluxes) |
---|
197 | IF( l_trd ) THEN |
---|
198 | ! store intermediate advective trends |
---|
199 | ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) |
---|
200 | END IF |
---|
201 | ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) |
---|
202 | IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN |
---|
203 | IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) |
---|
204 | IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) |
---|
205 | ENDIF |
---|
206 | |
---|
207 | ! 3. antidiffusive flux : high order minus low order |
---|
208 | ! -------------------------------------------------- |
---|
209 | ! antidiffusive flux on i and j |
---|
210 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
211 | DO jk = 1, jpkm1 |
---|
212 | DO jj = 1, jpjm1 |
---|
213 | DO ji = 1, fs_jpim1 ! vector opt. |
---|
214 | zwx(ji,jj,jk) = 0.5 * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) |
---|
215 | zwy(ji,jj,jk) = 0.5 * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) |
---|
216 | END DO |
---|
217 | END DO |
---|
218 | END DO |
---|
219 | |
---|
220 | ! antidiffusive flux on k |
---|
221 | ! Interior value |
---|
222 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
223 | DO jk = 2, jpkm1 |
---|
224 | DO jj = 1, jpj |
---|
225 | DO ji = 1, jpi |
---|
226 | zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) |
---|
227 | END DO |
---|
228 | END DO |
---|
229 | END DO |
---|
230 | ! surface value |
---|
231 | IF ( ln_isfcav ) THEN |
---|
232 | DO jj = 1, jpj |
---|
233 | DO ji = 1, jpi |
---|
234 | zwz(ji,jj,mikt(ji,jj)) = 0.e0 |
---|
235 | END DO |
---|
236 | END DO |
---|
237 | ELSE |
---|
238 | !$OMP PARALLEL WORKSHARE |
---|
239 | zwz(:,:,1) = 0.e0 |
---|
240 | !$OMP END PARALLEL WORKSHARE |
---|
241 | END IF |
---|
242 | CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions |
---|
243 | CALL lbc_lnk( zwz, 'W', 1. ) |
---|
244 | |
---|
245 | ! 4. monotonicity algorithm |
---|
246 | ! ------------------------- |
---|
247 | CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) |
---|
248 | |
---|
249 | |
---|
250 | ! 5. final trend with corrected fluxes |
---|
251 | ! ------------------------------------ |
---|
252 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zbtr, ztra) |
---|
253 | DO jk = 1, jpkm1 |
---|
254 | DO jj = 2, jpjm1 |
---|
255 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
256 | zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) |
---|
257 | ! total advective trends |
---|
258 | ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & |
---|
259 | & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & |
---|
260 | & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) |
---|
261 | ! add them to the general tracer trends |
---|
262 | pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) |
---|
263 | END DO |
---|
264 | END DO |
---|
265 | END DO |
---|
266 | |
---|
267 | ! ! trend diagnostics (contribution of upstream fluxes) |
---|
268 | IF( l_trd ) THEN |
---|
269 | ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed |
---|
270 | ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed |
---|
271 | ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed |
---|
272 | |
---|
273 | CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) |
---|
274 | CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) |
---|
275 | CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) |
---|
276 | END IF |
---|
277 | ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) |
---|
278 | IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN |
---|
279 | IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) |
---|
280 | IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) |
---|
281 | ENDIF |
---|
282 | ! |
---|
283 | END DO |
---|
284 | ! |
---|
285 | CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz ) |
---|
286 | IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) |
---|
287 | ! |
---|
288 | IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd') |
---|
289 | ! |
---|
290 | END SUBROUTINE tra_adv_tvd |
---|
291 | |
---|
292 | SUBROUTINE tra_adv_tvd_zts ( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & |
---|
293 | & ptb, ptn, pta, kjpt ) |
---|
294 | !!---------------------------------------------------------------------- |
---|
295 | !! *** ROUTINE tra_adv_tvd_zts *** |
---|
296 | !! |
---|
297 | !! ** Purpose : Compute the now trend due to total advection of |
---|
298 | !! tracers and add it to the general trend of tracer equations |
---|
299 | !! |
---|
300 | !! ** Method : TVD ZTS scheme, i.e. 2nd order centered scheme with |
---|
301 | !! corrected flux (monotonic correction). This version use sub- |
---|
302 | !! timestepping for the vertical advection which increases stability |
---|
303 | !! when vertical metrics are small. |
---|
304 | !! note: - this advection scheme needs a leap-frog time scheme |
---|
305 | !! |
---|
306 | !! ** Action : - update (pta) with the now advective tracer trends |
---|
307 | !! - save the trends |
---|
308 | !!---------------------------------------------------------------------- |
---|
309 | USE oce , ONLY: zwx => ua , zwy => va ! (ua,va) used as workspace |
---|
310 | ! |
---|
311 | INTEGER , INTENT(in ) :: kt ! ocean time-step index |
---|
312 | INTEGER , INTENT(in ) :: kit000 ! first time step index |
---|
313 | CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) |
---|
314 | INTEGER , INTENT(in ) :: kjpt ! number of tracers |
---|
315 | REAL(wp), DIMENSION( jpk ), INTENT(in ) :: p2dt ! vertical profile of tracer time-step |
---|
316 | REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components |
---|
317 | REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields |
---|
318 | REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend |
---|
319 | ! |
---|
320 | REAL(wp), DIMENSION( jpk ) :: zts ! length of sub-timestep for vertical advection |
---|
321 | REAL(wp), DIMENSION( jpk ) :: zr_p2dt ! reciprocal of tracer timestep |
---|
322 | INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices |
---|
323 | INTEGER :: jnzts = 5 ! number of sub-timesteps for vertical advection |
---|
324 | INTEGER :: jtb, jtn, jta ! sub timestep pointers for leap-frog/euler forward steps |
---|
325 | INTEGER :: jtaken ! toggle for collecting appropriate fluxes from sub timesteps |
---|
326 | REAL(wp) :: z_rzts ! Fractional length of Euler forward sub-timestep for vertical advection |
---|
327 | REAL(wp) :: z2dtt, zbtr, ztra ! local scalar |
---|
328 | REAL(wp) :: zfp_ui, zfp_vj, zfp_wk ! - - |
---|
329 | REAL(wp) :: zfm_ui, zfm_vj, zfm_wk ! - - |
---|
330 | REAL(wp), POINTER, DIMENSION(:,: ) :: zwx_sav , zwy_sav |
---|
331 | REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwz, zhdiv, zwz_sav, zwzts |
---|
332 | REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdx, ztrdy, ztrdz |
---|
333 | REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrs |
---|
334 | !!---------------------------------------------------------------------- |
---|
335 | ! |
---|
336 | IF( nn_timing == 1 ) CALL timing_start('tra_adv_tvd_zts') |
---|
337 | ! |
---|
338 | CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) |
---|
339 | CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) |
---|
340 | CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) |
---|
341 | ! |
---|
342 | IF( kt == kit000 ) THEN |
---|
343 | IF(lwp) WRITE(numout,*) |
---|
344 | IF(lwp) WRITE(numout,*) 'tra_adv_tvd_zts : TVD ZTS advection scheme on ', cdtype |
---|
345 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' |
---|
346 | ENDIF |
---|
347 | ! |
---|
348 | l_trd = .FALSE. |
---|
349 | IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. |
---|
350 | ! |
---|
351 | IF( l_trd ) THEN |
---|
352 | CALL wrk_alloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) |
---|
353 | !$OMP PARALLEL WORKSHARE |
---|
354 | ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp |
---|
355 | !$OMP END PARALLEL WORKSHARE |
---|
356 | ENDIF |
---|
357 | ! |
---|
358 | !$OMP PARALLEL WORKSHARE |
---|
359 | zwi(:,:,:) = 0._wp |
---|
360 | !$OMP END PARALLEL WORKSHARE |
---|
361 | z_rzts = 1._wp / REAL( jnzts, wp ) |
---|
362 | zr_p2dt(:) = 1._wp / p2dt(:) |
---|
363 | ! |
---|
364 | ! ! =========== |
---|
365 | DO jn = 1, kjpt ! tracer loop |
---|
366 | ! ! =========== |
---|
367 | ! 1. Bottom value : flux set to zero |
---|
368 | ! ---------------------------------- |
---|
369 | !$OMP PARALLEL WORKSHARE |
---|
370 | zwx(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp |
---|
371 | zwy(:,:,jpk) = 0._wp ; zwi(:,:,jpk) = 0._wp |
---|
372 | !$OMP END PARALLEL WORKSHARE |
---|
373 | ! 2. upstream advection with initial mass fluxes & intermediate update |
---|
374 | ! -------------------------------------------------------------------- |
---|
375 | ! upstream tracer flux in the i and j direction |
---|
376 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zfp_vj, zfm_vj, zfp_ui, zfm_ui) |
---|
377 | DO jk = 1, jpkm1 |
---|
378 | DO jj = 1, jpjm1 |
---|
379 | DO ji = 1, fs_jpim1 ! vector opt. |
---|
380 | ! upstream scheme |
---|
381 | zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) |
---|
382 | zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) |
---|
383 | zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) |
---|
384 | zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) |
---|
385 | zwx(ji,jj,jk) = 0.5_wp * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) ) |
---|
386 | zwy(ji,jj,jk) = 0.5_wp * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) ) |
---|
387 | END DO |
---|
388 | END DO |
---|
389 | END DO |
---|
390 | |
---|
391 | ! upstream tracer flux in the k direction |
---|
392 | ! Interior value |
---|
393 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zfp_wk, zfm_wk) |
---|
394 | DO jk = 2, jpkm1 |
---|
395 | DO jj = 1, jpj |
---|
396 | DO ji = 1, jpi |
---|
397 | zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) |
---|
398 | zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) |
---|
399 | zwz(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) |
---|
400 | END DO |
---|
401 | END DO |
---|
402 | END DO |
---|
403 | ! Surface value |
---|
404 | IF( lk_vvl ) THEN |
---|
405 | IF ( ln_isfcav ) THEN |
---|
406 | !$OMP PARALLEL DO schedule(static) private(jj, ji) |
---|
407 | DO jj = 1, jpj |
---|
408 | DO ji = 1, jpi |
---|
409 | zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable + isf |
---|
410 | END DO |
---|
411 | END DO |
---|
412 | ELSE |
---|
413 | !$OMP PARALLEL WORKSHARE |
---|
414 | zwz(:,:,1) = 0.e0 ! volume variable + no isf |
---|
415 | !$OMP END PARALLEL WORKSHARE |
---|
416 | END IF |
---|
417 | ELSE |
---|
418 | IF ( ln_isfcav ) THEN |
---|
419 | !$OMP PARALLEL DO schedule(static) private(jj, ji) |
---|
420 | DO jj = 1, jpj |
---|
421 | DO ji = 1, jpi |
---|
422 | zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface + isf |
---|
423 | END DO |
---|
424 | END DO |
---|
425 | ELSE |
---|
426 | !$OMP PARALLEL WORKSHARE |
---|
427 | zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface + no isf |
---|
428 | !$OMP END PARALLEL WORKSHARE |
---|
429 | END IF |
---|
430 | ENDIF |
---|
431 | |
---|
432 | ! total advective trend |
---|
433 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zbtr, ztra) |
---|
434 | DO jk = 1, jpkm1 |
---|
435 | z2dtt = p2dt(jk) |
---|
436 | DO jj = 2, jpjm1 |
---|
437 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
438 | zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) |
---|
439 | ! total intermediate advective trends |
---|
440 | ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & |
---|
441 | & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & |
---|
442 | & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) |
---|
443 | ! update and guess with monotonic sheme |
---|
444 | pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra |
---|
445 | zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) |
---|
446 | END DO |
---|
447 | END DO |
---|
448 | END DO |
---|
449 | ! ! Lateral boundary conditions on zwi (unchanged sign) |
---|
450 | CALL lbc_lnk( zwi, 'T', 1. ) |
---|
451 | |
---|
452 | ! ! trend diagnostics (contribution of upstream fluxes) |
---|
453 | IF( l_trd ) THEN |
---|
454 | ! store intermediate advective trends |
---|
455 | !$OMP PARALLEL WORKSHARE |
---|
456 | ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) |
---|
457 | !$OMP END PARALLEL WORKSHARE |
---|
458 | END IF |
---|
459 | ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) |
---|
460 | IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN |
---|
461 | IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) |
---|
462 | IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) |
---|
463 | ENDIF |
---|
464 | |
---|
465 | ! 3. antidiffusive flux : high order minus low order |
---|
466 | ! -------------------------------------------------- |
---|
467 | ! antidiffusive flux on i and j |
---|
468 | |
---|
469 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
470 | DO jk = 1, jpkm1 |
---|
471 | |
---|
472 | DO jj = 1, jpjm1 |
---|
473 | DO ji = 1, fs_jpim1 ! vector opt. |
---|
474 | zwx_sav(ji,jj) = zwx(ji,jj,jk) |
---|
475 | zwy_sav(ji,jj) = zwy(ji,jj,jk) |
---|
476 | |
---|
477 | zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) |
---|
478 | zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) |
---|
479 | END DO |
---|
480 | END DO |
---|
481 | !$OMP PARALLEL DO schedule(static) private(jj, ji) |
---|
482 | DO jj = 2, jpjm1 ! partial horizontal divergence |
---|
483 | DO ji = fs_2, fs_jpim1 |
---|
484 | zhdiv(ji,jj,jk) = ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & |
---|
485 | & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) |
---|
486 | END DO |
---|
487 | END DO |
---|
488 | !$OMP PARALLEL DO schedule(static) private(jj, ji) |
---|
489 | DO jj = 1, jpjm1 |
---|
490 | DO ji = 1, fs_jpim1 ! vector opt. |
---|
491 | zwx(ji,jj,jk) = zwx(ji,jj,jk) - zwx_sav(ji,jj) |
---|
492 | zwy(ji,jj,jk) = zwy(ji,jj,jk) - zwy_sav(ji,jj) |
---|
493 | END DO |
---|
494 | END DO |
---|
495 | END DO |
---|
496 | |
---|
497 | ! antidiffusive flux on k |
---|
498 | !$OMP PARALLEL WORKSHARE |
---|
499 | zwz(:,:,1) = 0._wp ! Surface value |
---|
500 | zwz_sav(:,:,:) = zwz(:,:,:) |
---|
501 | ! |
---|
502 | ztrs(:,:,:,1) = ptb(:,:,:,jn) |
---|
503 | zwzts(:,:,:) = 0._wp |
---|
504 | !$OMP END PARALLEL WORKSHARE |
---|
505 | DO jl = 1, jnzts ! Start of sub timestepping loop |
---|
506 | |
---|
507 | IF( jl == 1 ) THEN ! Euler forward to kick things off |
---|
508 | jtb = 1 ; jtn = 1 ; jta = 2 |
---|
509 | zts(:) = p2dt(:) * z_rzts |
---|
510 | jtaken = MOD( jnzts + 1 , 2) ! Toggle to collect every second flux |
---|
511 | ! starting at jl =1 if jnzts is odd; |
---|
512 | ! starting at jl =2 otherwise |
---|
513 | ELSEIF( jl == 2 ) THEN ! First leapfrog step |
---|
514 | jtb = 1 ; jtn = 2 ; jta = 3 |
---|
515 | zts(:) = 2._wp * p2dt(:) * z_rzts |
---|
516 | ELSE ! Shuffle pointers for subsequent leapfrog steps |
---|
517 | jtb = MOD(jtb,3) + 1 |
---|
518 | jtn = MOD(jtn,3) + 1 |
---|
519 | jta = MOD(jta,3) + 1 |
---|
520 | ENDIF |
---|
521 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
522 | DO jk = 2, jpkm1 ! Interior value |
---|
523 | DO jj = 2, jpjm1 |
---|
524 | DO ji = fs_2, fs_jpim1 |
---|
525 | zwz(ji,jj,jk) = 0.5_wp * pwn(ji,jj,jk) * ( ztrs(ji,jj,jk,jtn) + ztrs(ji,jj,jk-1,jtn) ) |
---|
526 | IF( jtaken == 0 ) zwzts(ji,jj,jk) = zwzts(ji,jj,jk) + zwz(ji,jj,jk)*zts(jk) ! Accumulate time-weighted vertcal flux |
---|
527 | END DO |
---|
528 | END DO |
---|
529 | END DO |
---|
530 | |
---|
531 | jtaken = MOD( jtaken + 1 , 2 ) |
---|
532 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zbtr, ztra) |
---|
533 | DO jk = 2, jpkm1 ! Interior value |
---|
534 | DO jj = 2, jpjm1 |
---|
535 | DO ji = fs_2, fs_jpim1 |
---|
536 | zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) |
---|
537 | ! total advective trends |
---|
538 | ztra = - zbtr * ( zhdiv(ji,jj,jk) + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) |
---|
539 | ztrs(ji,jj,jk,jta) = ztrs(ji,jj,jk,jtb) + zts(jk) * ztra |
---|
540 | END DO |
---|
541 | END DO |
---|
542 | END DO |
---|
543 | |
---|
544 | END DO |
---|
545 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
546 | DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping |
---|
547 | DO jj = 2, jpjm1 |
---|
548 | DO ji = fs_2, fs_jpim1 |
---|
549 | zwz(ji,jj,jk) = zwzts(ji,jj,jk) * zr_p2dt(jk) - zwz_sav(ji,jj,jk) |
---|
550 | END DO |
---|
551 | END DO |
---|
552 | END DO |
---|
553 | CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions |
---|
554 | CALL lbc_lnk( zwz, 'W', 1. ) |
---|
555 | |
---|
556 | ! 4. monotonicity algorithm |
---|
557 | ! ------------------------- |
---|
558 | CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) |
---|
559 | |
---|
560 | |
---|
561 | ! 5. final trend with corrected fluxes |
---|
562 | ! ------------------------------------ |
---|
563 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zbtr, ztra) |
---|
564 | DO jk = 1, jpkm1 |
---|
565 | DO jj = 2, jpjm1 |
---|
566 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
567 | zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) |
---|
568 | ! total advective trends |
---|
569 | ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & |
---|
570 | & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & |
---|
571 | & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) |
---|
572 | ! add them to the general tracer trends |
---|
573 | pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra |
---|
574 | END DO |
---|
575 | END DO |
---|
576 | END DO |
---|
577 | |
---|
578 | ! ! trend diagnostics (contribution of upstream fluxes) |
---|
579 | IF( l_trd ) THEN |
---|
580 | !$OMP PARALLEL WORKSHARE |
---|
581 | ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed |
---|
582 | ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed |
---|
583 | ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed |
---|
584 | !$OMP END PARALLEL WORKSHARE |
---|
585 | CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) |
---|
586 | CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) |
---|
587 | CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) |
---|
588 | END IF |
---|
589 | ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) |
---|
590 | IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN |
---|
591 | IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) |
---|
592 | IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) |
---|
593 | ENDIF |
---|
594 | ! |
---|
595 | END DO |
---|
596 | ! |
---|
597 | CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) |
---|
598 | CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) |
---|
599 | CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) |
---|
600 | IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) |
---|
601 | ! |
---|
602 | IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd_zts') |
---|
603 | ! |
---|
604 | END SUBROUTINE tra_adv_tvd_zts |
---|
605 | |
---|
606 | SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) |
---|
607 | !!--------------------------------------------------------------------- |
---|
608 | !! *** ROUTINE nonosc *** |
---|
609 | !! |
---|
610 | !! ** Purpose : compute monotonic tracer fluxes from the upstream |
---|
611 | !! scheme and the before field by a nonoscillatory algorithm |
---|
612 | !! |
---|
613 | !! ** Method : ... ??? |
---|
614 | !! warning : pbef and paft must be masked, but the boundaries |
---|
615 | !! conditions on the fluxes are not necessary zalezak (1979) |
---|
616 | !! drange (1995) multi-dimensional forward-in-time and upstream- |
---|
617 | !! in-space based differencing for fluid |
---|
618 | !!---------------------------------------------------------------------- |
---|
619 | REAL(wp), DIMENSION(jpk) , INTENT(in ) :: p2dt ! vertical profile of tracer time-step |
---|
620 | REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field |
---|
621 | REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions |
---|
622 | ! |
---|
623 | INTEGER :: ji, jj, jk ! dummy loop indices |
---|
624 | INTEGER :: ikm1 ! local integer |
---|
625 | REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn, z2dtt ! local scalars |
---|
626 | REAL(wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - |
---|
627 | REAL(wp), POINTER, DIMENSION(:,:,:) :: zbetup, zbetdo, zbup, zbdo |
---|
628 | !!---------------------------------------------------------------------- |
---|
629 | ! |
---|
630 | IF( nn_timing == 1 ) CALL timing_start('nonosc') |
---|
631 | ! |
---|
632 | CALL wrk_alloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) |
---|
633 | ! |
---|
634 | zbig = 1.e+40_wp |
---|
635 | zrtrn = 1.e-15_wp |
---|
636 | !$OMP PARALLEL WORKSHARE |
---|
637 | zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp |
---|
638 | !$OMP END PARALLEL WORKSHARE |
---|
639 | ! Search local extrema |
---|
640 | ! -------------------- |
---|
641 | ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land |
---|
642 | !zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & |
---|
643 | ! & paft * tmask - zbig * ( 1._wp - tmask ) ) |
---|
644 | !zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & |
---|
645 | ! & paft * tmask + zbig * ( 1._wp - tmask ) ) |
---|
646 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji) |
---|
647 | DO jk = 1, jpk |
---|
648 | DO jj = 1, jpj |
---|
649 | !DIR$ IVDEP |
---|
650 | DO ji = 1, jpi |
---|
651 | zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & |
---|
652 | & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) |
---|
653 | zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & |
---|
654 | & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) |
---|
655 | END DO |
---|
656 | END DO |
---|
657 | END DO |
---|
658 | |
---|
659 | |
---|
660 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, zpos, zneg, zbt, ikm1, z2dtt, zup, zdo) |
---|
661 | DO jk = 1, jpkm1 |
---|
662 | ikm1 = MAX(jk-1,1) |
---|
663 | z2dtt = p2dt(jk) |
---|
664 | DO jj = 2, jpjm1 |
---|
665 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
666 | |
---|
667 | ! search maximum in neighbourhood |
---|
668 | zup = MAX( zbup(ji ,jj ,jk ), & |
---|
669 | & zbup(ji-1,jj ,jk ), zbup(ji+1,jj ,jk ), & |
---|
670 | & zbup(ji ,jj-1,jk ), zbup(ji ,jj+1,jk ), & |
---|
671 | & zbup(ji ,jj ,ikm1), zbup(ji ,jj ,jk+1) ) |
---|
672 | |
---|
673 | ! search minimum in neighbourhood |
---|
674 | zdo = MIN( zbdo(ji ,jj ,jk ), & |
---|
675 | & zbdo(ji-1,jj ,jk ), zbdo(ji+1,jj ,jk ), & |
---|
676 | & zbdo(ji ,jj-1,jk ), zbdo(ji ,jj+1,jk ), & |
---|
677 | & zbdo(ji ,jj ,ikm1), zbdo(ji ,jj ,jk+1) ) |
---|
678 | |
---|
679 | ! positive part of the flux |
---|
680 | zpos = MAX( 0., paa(ji-1,jj ,jk ) ) - MIN( 0., paa(ji ,jj ,jk ) ) & |
---|
681 | & + MAX( 0., pbb(ji ,jj-1,jk ) ) - MIN( 0., pbb(ji ,jj ,jk ) ) & |
---|
682 | & + MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) |
---|
683 | |
---|
684 | ! negative part of the flux |
---|
685 | zneg = MAX( 0., paa(ji ,jj ,jk ) ) - MIN( 0., paa(ji-1,jj ,jk ) ) & |
---|
686 | & + MAX( 0., pbb(ji ,jj ,jk ) ) - MIN( 0., pbb(ji ,jj-1,jk ) ) & |
---|
687 | & + MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) |
---|
688 | |
---|
689 | ! up & down beta terms |
---|
690 | zbt = e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) / z2dtt |
---|
691 | zbetup(ji,jj,jk) = ( zup - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt |
---|
692 | zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo ) / ( zneg + zrtrn ) * zbt |
---|
693 | END DO |
---|
694 | END DO |
---|
695 | END DO |
---|
696 | CALL lbc_lnk( zbetup, 'T', 1. ) ; CALL lbc_lnk( zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign) |
---|
697 | |
---|
698 | ! 3. monotonic flux in the i & j direction (paa & pbb) |
---|
699 | ! ---------------------------------------- |
---|
700 | !$OMP PARALLEL DO schedule(static) private(jk, jj, ji, za, zb, zc, zav, zbv, zcv, zau, zbu, zcu) |
---|
701 | DO jk = 1, jpkm1 |
---|
702 | DO jj = 2, jpjm1 |
---|
703 | DO ji = fs_2, fs_jpim1 ! vector opt. |
---|
704 | zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) |
---|
705 | zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) |
---|
706 | zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) ) |
---|
707 | paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) |
---|
708 | |
---|
709 | zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) |
---|
710 | zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) |
---|
711 | zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) ) |
---|
712 | pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) |
---|
713 | |
---|
714 | ! monotonic flux in the k direction, i.e. pcc |
---|
715 | ! ------------------------------------------- |
---|
716 | za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) |
---|
717 | zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) |
---|
718 | zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) |
---|
719 | pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) |
---|
720 | END DO |
---|
721 | END DO |
---|
722 | END DO |
---|
723 | CALL lbc_lnk( paa, 'U', -1. ) ; CALL lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) |
---|
724 | ! |
---|
725 | CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) |
---|
726 | ! |
---|
727 | IF( nn_timing == 1 ) CALL timing_stop('nonosc') |
---|
728 | ! |
---|
729 | END SUBROUTINE nonosc |
---|
730 | |
---|
731 | !!====================================================================== |
---|
732 | END MODULE traadv_tvd |
---|