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

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

last commit documented

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