source: palm/trunk/SOURCE/prandtl_fluxes.f90 @ 1277

Last change on this file since 1277 was 1277, checked in by heinze, 8 years ago

Last commit documented

  • Property svn:keywords set to Id
File size: 15.3 KB
Line 
1 SUBROUTINE prandtl_fluxes
2
3!--------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2012  Leibniz University Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: prandtl_fluxes.f90 1277 2014-01-15 13:43:45Z heinze $
27!
28! 1276 2014-01-15 13:40:41Z heinze
29! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
30!
31! 1257 2013-11-08 15:18:40Z raasch
32! openACC "kernels do" replaced by "kernels loop", "loop independent" added
33!
34! 1036 2012-10-22 13:43:42Z raasch
35! code put under GPL (PALM 3.9)
36!
37! 1015 2012-09-27 09:23:24Z raasch
38! OpenACC statements added
39!
40! 978 2012-08-09 08:28:32Z fricke
41! roughness length for scalar quantities z0h added
42!
43! 759 2011-09-15 13:58:31Z raasch
44! Bugfix for ts limitation
45!
46! 709 2011-03-30 09:31:40Z raasch
47! formatting adjustments
48!
49! 667 2010-12-23 12:06:00Z suehring/gryschka
50! Changed surface boundary conditions for u and v from mirror to Dirichlet.
51! Therefore u(uzb,:,:) and v(nzb,:,:) are now representative for height z0.
52! nxl-1, nxr+1, nys-1, nyn+1 replaced by nxlg, nxrg, nysg, nyng
53!
54! 315 2009-05-13 10:57:59Z raasch
55! Saturation condition at (sea) surface is not used in precursor runs (only
56! in the following coupled runs)
57! Bugfix: qsws was calculated in case of constant heatflux = .FALSE.
58!
59! 187 2008-08-06 16:25:09Z letzel
60! Bugfix: modification of the calculation of the vertical turbulent momentum
61! fluxes u'w' and v'w'
62! Bugfix: change definition of us_wall from 1D to 2D
63! Change: modification of the integrated version of the profile function for
64! momentum for unstable stratification (does not effect results)
65!
66! 108 2007-08-24 15:10:38Z letzel
67! assume saturation at k=nzb_s_inner(j,i) for atmosphere coupled to ocean
68!
69! 75 2007-03-22 09:54:05Z raasch
70! moisture renamed humidity
71!
72! RCS Log replace by Id keyword, revision history cleaned up
73!
74! Revision 1.19  2006/04/26 12:24:35  raasch
75! +OpenMP directives and optimization (array assignments replaced by DO loops)
76!
77! Revision 1.1  1998/01/23 10:06:06  raasch
78! Initial revision
79!
80!
81! Description:
82! ------------
83! Diagnostic computation of vertical fluxes in the Prandtl layer from the
84! values of the variables at grid point k=1
85!------------------------------------------------------------------------------!
86
87    USE arrays_3d
88    USE control_parameters
89    USE grid_variables
90    USE indices
91
92    IMPLICIT NONE
93
94    INTEGER ::  i, j, k
95    LOGICAL ::  coupled_run
96    REAL    ::  a, b, e_q, rifm, uv_total, z_p
97
98!
99!-- Data information for accelerators
100    !$acc data present( e, nzb_u_inner, nzb_v_inner, nzb_s_inner, pt, q, qs ) &
101    !$acc      present( qsws, rif, shf, ts, u, us, usws, v, vpt, vsws, zu, zw, z0, z0h )
102!
103!-- Compute theta*
104    IF ( constant_heatflux )  THEN
105!
106!--    For a given heat flux in the Prandtl layer:
107!--    for u* use the value from the previous time step
108       !$OMP PARALLEL DO
109       !$acc kernels loop
110       DO  i = nxlg, nxrg
111          DO  j = nysg, nyng
112             ts(j,i) = -shf(j,i) / ( us(j,i) + 1E-30 )
113!
114!--          ts must be limited, because otherwise overflow may occur in case of
115!--          us=0 when computing rif further below
116             IF ( ts(j,i) < -1.05E5 )  ts(j,i) = -1.0E5
117             IF ( ts(j,i) >   1.0E5 )  ts(j,i) =  1.0E5
118          ENDDO
119       ENDDO
120
121    ELSE
122!
123!--    For a given surface temperature:
124!--    (the Richardson number is still the one from the previous time step)
125   
126       IF ( large_scale_forcing .AND. lsf_surf )  THEN
127          pt(0,:,:) = pt_surface
128       ENDIF
129
130       !$OMP PARALLEL DO PRIVATE( a, b, k, z_p )
131       !$acc kernels loop
132       DO  i = nxlg, nxrg
133          DO  j = nysg, nyng
134
135             k   = nzb_s_inner(j,i)
136             z_p = zu(k+1) - zw(k)
137
138             IF ( rif(j,i) >= 0.0 )  THEN
139!
140!--             Stable stratification
141                ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) / (           &
142                                  LOG( z_p / z0h(j,i) ) +                   &
143                                  5.0 * rif(j,i) * ( z_p - z0h(j,i) ) / z_p &
144                                                                )
145             ELSE
146!
147!--             Unstable stratification
148                a = SQRT( 1.0 - 16.0 * rif(j,i) )
149                b = SQRT( 1.0 - 16.0 * rif(j,i) * z0h(j,i) / z_p )
150
151                ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) ) /  (          &
152                          LOG( z_p / z0h(j,i) ) -                           &
153                          2.0 * LOG( ( 1.0 + a ) / ( 1.0 + b ) ) )
154             ENDIF
155
156          ENDDO
157       ENDDO
158    ENDIF
159
160!
161!-- Compute z_p/L (corresponds to the Richardson-flux number)
162    IF ( .NOT. humidity )  THEN
163       !$OMP PARALLEL DO PRIVATE( k, z_p )
164       !$acc kernels loop
165       DO  i = nxlg, nxrg
166          DO  j = nysg, nyng
167             k   = nzb_s_inner(j,i)
168             z_p = zu(k+1) - zw(k)
169             rif(j,i) = z_p * kappa * g * ts(j,i) / &
170                        ( pt(k+1,j,i) * ( us(j,i)**2 + 1E-30 ) )
171!
172!--          Limit the value range of the Richardson numbers.
173!--          This is necessary for very small velocities (u,v --> 0), because
174!--          the absolute value of rif can then become very large, which in
175!--          consequence would result in very large shear stresses and very
176!--          small momentum fluxes (both are generally unrealistic).
177             IF ( rif(j,i) < rif_min )  rif(j,i) = rif_min
178             IF ( rif(j,i) > rif_max )  rif(j,i) = rif_max
179          ENDDO
180       ENDDO
181    ELSE
182       !$OMP PARALLEL DO PRIVATE( k, z_p )
183       !$acc kernels loop
184       DO  i = nxlg, nxrg
185          DO  j = nysg, nyng
186             k   = nzb_s_inner(j,i)
187             z_p = zu(k+1) - zw(k)
188             rif(j,i) = z_p * kappa * g *                            &
189                        ( ts(j,i) + 0.61 * pt(k+1,j,i) * qs(j,i) ) / &
190                        ( vpt(k+1,j,i) * ( us(j,i)**2 + 1E-30 ) )
191!
192!--          Limit the value range of the Richardson numbers.
193!--          This is necessary for very small velocities (u,v --> 0), because
194!--          the absolute value of rif can then become very large, which in
195!--          consequence would result in very large shear stresses and very
196!--          small momentum fluxes (both are generally unrealistic).
197             IF ( rif(j,i) < rif_min )  rif(j,i) = rif_min
198             IF ( rif(j,i) > rif_max )  rif(j,i) = rif_max
199          ENDDO
200       ENDDO       
201    ENDIF
202
203!
204!-- Compute u* at the scalars' grid points
205    !$OMP PARALLEL DO PRIVATE( a, b, k, uv_total, z_p )
206    !$acc kernels loop
207    DO  i = nxl, nxr
208       DO  j = nys, nyn
209
210          k   = nzb_s_inner(j,i)
211          z_p = zu(k+1) - zw(k)
212
213!
214!--       Compute the absolute value of the horizontal velocity
215!--       (relative to the surface)
216          uv_total = SQRT( ( 0.5 * ( u(k+1,j,i) + u(k+1,j,i+1)        &
217                                   - u(k,j,i)   - u(k,j,i+1) ) )**2 + &
218                           ( 0.5 * ( v(k+1,j,i) + v(k+1,j+1,i)        &
219                                   - v(k,j,i)   - v(k,j+1,i) ) )**2 )   
220
221
222          IF ( rif(j,i) >= 0.0 )  THEN
223!
224!--          Stable stratification
225             us(j,i) = kappa * uv_total / (                                &
226                                  LOG( z_p / z0(j,i) ) +                   &
227                                  5.0 * rif(j,i) * ( z_p - z0(j,i) ) / z_p &
228                                          )
229          ELSE
230!
231!--          Unstable stratification
232             a = SQRT( SQRT( 1.0 - 16.0 * rif(j,i) ) )
233             b = SQRT( SQRT( 1.0 - 16.0 * rif(j,i) / z_p * z0(j,i) ) )
234
235             us(j,i) = kappa * uv_total / (                                  &
236                       LOG( z_p / z0(j,i) ) -                                &
237                       LOG( ( 1.0 + a )**2 * ( 1.0 + a**2 ) / (              &
238                            ( 1.0 + b )**2 * ( 1.0 + b**2 )   ) ) +          &
239                            2.0 * ( ATAN( a ) - ATAN( b ) )                  &
240                                           )
241          ENDIF
242       ENDDO
243    ENDDO
244
245!
246!-- Values of us at ghost point locations are needed for the evaluation of usws
247!-- and vsws.
248    !$acc update host( us )
249    CALL exchange_horiz_2d( us )
250    !$acc update device( us )
251
252!
253!-- Compute u'w' for the total model domain.
254!-- First compute the corresponding component of u* and square it.
255    !$OMP PARALLEL DO PRIVATE( a, b, k, rifm, z_p )
256    !$acc kernels loop
257    DO  i = nxl, nxr
258       DO  j = nys, nyn
259
260          k   = nzb_u_inner(j,i)
261          z_p = zu(k+1) - zw(k)
262
263!
264!--       Compute Richardson-flux number for this point
265          rifm = 0.5 * ( rif(j,i-1) + rif(j,i) )
266          IF ( rifm >= 0.0 )  THEN
267!
268!--          Stable stratification
269             usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) )/ (              &
270                                     LOG( z_p / z0(j,i) ) +               &
271                                     5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
272                                              )
273          ELSE
274!
275!--          Unstable stratification
276             a = SQRT( SQRT( 1.0 - 16.0 * rifm ) )
277             b = SQRT( SQRT( 1.0 - 16.0 * rifm / z_p * z0(j,i) ) )
278
279             usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) ) / (            &
280                         LOG( z_p / z0(j,i) ) -                           &
281                         LOG( (1.0 + a )**2 * ( 1.0 + a**2 ) / (          &
282                              (1.0 + b )**2 * ( 1.0 + b**2 )   ) ) +      &
283                              2.0 * ( ATAN( a ) - ATAN( b ) )             &
284                                                 )
285          ENDIF
286          usws(j,i) = -usws(j,i) * 0.5 * ( us(j,i-1) + us(j,i) )
287       ENDDO
288    ENDDO
289
290!
291!-- Compute v'w' for the total model domain.
292!-- First compute the corresponding component of u* and square it.
293    !$OMP PARALLEL DO PRIVATE( a, b, k, rifm, z_p )
294    !$acc kernels loop
295    DO  i = nxl, nxr
296       DO  j = nys, nyn
297
298          k   = nzb_v_inner(j,i)
299          z_p = zu(k+1) - zw(k)
300
301!
302!--       Compute Richardson-flux number for this point
303          rifm = 0.5 * ( rif(j-1,i) + rif(j,i) )
304          IF ( rifm >= 0.0 )  THEN
305!
306!--          Stable stratification
307             vsws(j,i) = kappa * ( v(k+1,j,i) -  v(k,j,i) ) / (           &
308                                     LOG( z_p / z0(j,i) ) +               &
309                                     5.0 * rifm * ( z_p - z0(j,i) ) / z_p &
310                                              )
311          ELSE
312!
313!--          Unstable stratification
314             a = SQRT( SQRT( 1.0 - 16.0 * rifm ) )
315             b = SQRT( SQRT( 1.0 - 16.0 * rifm / z_p * z0(j,i) ) )
316
317             vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) ) / (            &
318                         LOG( z_p / z0(j,i) ) -                           &
319                         LOG( (1.0 + a )**2 * ( 1.0 + a**2 ) / (          &
320                              (1.0 + b )**2 * ( 1.0 + b**2 )   ) ) +      &
321                              2.0 * ( ATAN( a ) - ATAN( b ) )             &
322                                                 )
323          ENDIF
324          vsws(j,i) = -vsws(j,i) * 0.5 * ( us(j-1,i) + us(j,i) )
325       ENDDO
326    ENDDO
327
328!
329!-- If required compute q*
330    IF ( humidity  .OR.  passive_scalar )  THEN
331       IF ( constant_waterflux )  THEN
332!
333!--       For a given water flux in the Prandtl layer:
334          !$OMP PARALLEL DO
335          !$acc kernels loop
336          DO  i = nxlg, nxrg
337             DO  j = nysg, nyng
338                qs(j,i) = -qsws(j,i) / ( us(j,i) + 1E-30 )
339             ENDDO
340          ENDDO
341         
342       ELSE
343          coupled_run = ( coupling_mode == 'atmosphere_to_ocean' .AND. run_coupled )
344
345           IF ( large_scale_forcing .AND. lsf_surf )  THEN
346              q(0,:,:) = q_surface
347           ENDIF
348
349          !$OMP PARALLEL DO PRIVATE( a, b, k, z_p )
350          !$acc kernels loop independent
351          DO  i = nxlg, nxrg
352             !$acc loop independent
353             DO  j = nysg, nyng
354
355                k   = nzb_s_inner(j,i)
356                z_p = zu(k+1) - zw(k)
357
358!
359!--             Assume saturation for atmosphere coupled to ocean (but not
360!--             in case of precursor runs)
361                IF ( coupled_run )  THEN
362                   e_q = 6.1 * &
363                        EXP( 0.07 * ( MIN(pt(0,j,i),pt(1,j,i)) - 273.15 ) )
364                   q(k,j,i) = 0.622 * e_q / ( surface_pressure - e_q )
365                ENDIF
366                IF ( rif(j,i) >= 0.0 )  THEN
367!
368!--                Stable stratification
369                   qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) / (          &
370                                  LOG( z_p / z0h(j,i) ) +                   &
371                                  5.0 * rif(j,i) * ( z_p - z0h(j,i) ) / z_p &
372                                                                 )
373                ELSE
374!
375!--                Unstable stratification
376                   a = SQRT( 1.0 - 16.0 * rif(j,i) ) 
377                   b = SQRT( 1.0 - 16.0 * rif(j,i) * z0h(j,i) / z_p ) 
378 
379                   qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) ) /   (        &
380                             LOG( z_p / z0h(j,i) ) -                        &
381                              2.0 * LOG( (1.0 + a ) / ( 1.0 + b ) ) )
382                ENDIF
383
384             ENDDO
385          ENDDO
386       ENDIF
387    ENDIF
388
389!
390!-- Exchange the boundaries for the momentum fluxes (only for sake of
391!-- completeness)
392    !$acc update host( usws, vsws )
393    CALL exchange_horiz_2d( usws )
394    CALL exchange_horiz_2d( vsws )
395    !$acc update device( usws, vsws )
396    IF ( humidity  .OR.  passive_scalar )  THEN
397       !$acc update host( qsws )
398       CALL exchange_horiz_2d( qsws )
399       !$acc update device( qsws )
400    ENDIF
401
402!
403!-- Compute the vertical kinematic heat flux
404    IF ( .NOT. constant_heatflux )  THEN
405       !$OMP PARALLEL DO
406       !$acc kernels loop independent
407       DO  i = nxlg, nxrg
408          !$acc loop independent
409          DO  j = nysg, nyng
410             shf(j,i) = -ts(j,i) * us(j,i)
411          ENDDO
412       ENDDO
413    ENDIF
414
415!
416!-- Compute the vertical water/scalar flux
417    IF ( .NOT. constant_waterflux .AND. ( humidity .OR. passive_scalar ) ) THEN
418       !$OMP PARALLEL DO
419       !$acc kernels loop independent
420       DO  i = nxlg, nxrg
421          !$acc loop independent
422          DO  j = nysg, nyng
423             qsws(j,i) = -qs(j,i) * us(j,i)
424          ENDDO
425       ENDDO
426    ENDIF
427
428!
429!-- Bottom boundary condition for the TKE
430    IF ( ibc_e_b == 2 )  THEN
431       !$OMP PARALLEL DO
432       !$acc kernels loop independent
433       DO  i = nxlg, nxrg
434          !$acc loop independent
435          DO  j = nysg, nyng
436             e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.1 )**2
437!
438!--          As a test: cm = 0.4
439!            e(nzb_s_inner(j,i)+1,j,i) = ( us(j,i) / 0.4 )**2
440             e(nzb_s_inner(j,i),j,i)   = e(nzb_s_inner(j,i)+1,j,i)
441          ENDDO
442       ENDDO
443    ENDIF
444
445    !$acc end data
446
447 END SUBROUTINE prandtl_fluxes
Note: See TracBrowser for help on using the repository browser.