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

Last change on this file since 1036 was 1036, checked in by raasch, 9 years ago

code has been put under the GNU General Public License (v3)

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