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

Last change on this file since 1361 was 1361, checked in by hoffmann, 10 years ago

improved version of two-moment cloud physics

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