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

Last change on this file since 1321 was 1321, checked in by raasch, 7 years ago

last commit documented

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