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

Last change on this file since 1028 was 1017, checked in by raasch, 12 years ago

last commit documented

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