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

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

ONLY-attribute added to USE-statements,
kind-parameters added to all INTEGER and REAL declaration statements,
kinds are defined in new module kinds,
old module precision_kind is removed,
revision history before 2012 removed,
comment fields (!:) to be used for variable explanations added to all variable declaration statements

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