source: palm/trunk/SOURCE/surface_layer_fluxes_mod.f90 @ 2119

Last change on this file since 2119 was 2119, checked in by raasch, 4 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 43.0 KB
Line 
1!> @file surface_layer_fluxes_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! 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-2017 Leibniz Universitaet Hannover
18!
19!------------------------------------------------------------------------------!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: surface_layer_fluxes_mod.f90 2119 2017-01-17 16:51:50Z raasch $
27!
28! 2118 2017-01-17 16:38:49Z raasch
29! OpenACC directives and related code removed
30!
31! 2091 2016-12-21 16:38:18Z suehring
32! Bugfix in calculation of vsws ( incorrect linear interpolation of us )
33!
34! 2076 2016-12-02 13:54:20Z raasch
35! further openmp bugfix for lookup method
36!
37! 2073 2016-11-30 14:34:05Z raasch
38! openmp bugfix for lookup method
39!
40! 2037 2016-10-26 11:15:40Z knoop
41! Anelastic approximation implemented
42!
43! 2011 2016-09-19 17:29:57Z kanani
44! Flag urban_surface is now defined in module control_parameters.
45!
46! 2007 2016-08-24 15:47:17Z kanani
47! Account for urban surface model in computation of vertical kinematic heatflux
48!
49! 2000 2016-08-20 18:09:15Z knoop
50! Forced header and separation lines into 80 columns
51!
52! 1992 2016-08-12 15:14:59Z suehring
53! Minor bug, declaration of look-up index as INTEGER
54!
55! 1960 2016-07-12 16:34:24Z suehring
56! Treat humidity and passive scalar separately
57!
58! 1929 2016-06-09 16:25:25Z suehring
59! Bugfix: avoid segmentation fault in case one grid point is horizontally
60! completely surrounded by topography
61!
62! 1920 2016-05-30 10:50:15Z suehring
63! Avoid segmentation fault (see change in 1915) by different initialization of
64! us instead of adding a very small number in the denominator
65!
66! 1915 2016-05-27 11:05:02Z suehring
67! Bugfix: avoid segmentation fault in case of most_method = 'circular' at first
68! timestep
69!
70! 1850 2016-04-08 13:29:27Z maronga
71! Module renamed
72!
73!
74! 1822 2016-04-07 07:49:42Z hoffmann
75! icloud_scheme replaced by microphysics_*
76!
77! 1788 2016-03-10 11:01:04Z maronga
78! Added parameter z0q which replaces z0h in the similarity functions for
79! humidity.
80! Syntax layout improved.
81!
82! 1757 2016-02-22 15:49:32Z maronga
83! Minor fixes.
84!
85! 1749 2016-02-09 12:19:56Z raasch
86! further OpenACC adjustments
87!
88! 1747 2016-02-08 12:25:53Z raasch
89! adjustments for OpenACC usage
90!
91! 1709 2015-11-04 14:47:01Z maronga
92! Bugfix: division by zero could occur when calculating rib at low wind speeds
93! Bugfix: calculation of uv_total for neutral = .T., initial value for ol for
94! neutral = .T.
95!
96! 1705 2015-11-02 14:28:56Z maronga
97! Typo removed
98!
99! 1697 2015-10-28 17:14:10Z raasch
100! FORTRAN and OpenMP errors removed
101!
102! 1696 2015-10-27 10:03:34Z maronga
103! Modularized and completely re-written version of prandtl_fluxes.f90. In the
104! course of the re-writing two additional methods have been implemented. See
105! updated description.
106!
107! 1551 2015-03-03 14:18:16Z maronga
108! Removed land surface model part. The surface fluxes are now always calculated
109! within prandtl_fluxes, based on the given surface temperature/humidity (which
110! is either provided by the land surface model, by large scale forcing data, or
111! directly prescribed by the user.
112!
113! 1496 2014-12-02 17:25:50Z maronga
114! Adapted for land surface model
115!
116! 1494 2014-11-21 17:14:03Z maronga
117! Bugfixes: qs is now calculated before calculation of Rif. calculation of
118! buoyancy flux in Rif corrected (added missing humidity term), allow use of
119! topography for coupled runs (not tested)
120!
121! 1361 2014-04-16 15:17:48Z hoffmann
122! Bugfix: calculation of turbulent fluxes of rain water content (qrsws) and rain
123! drop concentration (nrsws) added
124!
125! 1340 2014-03-25 19:45:13Z kanani
126! REAL constants defined as wp-kind
127!
128! 1320 2014-03-20 08:40:49Z raasch
129! ONLY-attribute added to USE-statements,
130! kind-parameters added to all INTEGER and REAL declaration statements,
131! kinds are defined in new module kinds,
132! old module precision_kind is removed,
133! revision history before 2012 removed,
134! comment fields (!:) to be used for variable explanations added to
135! all variable declaration statements
136!
137! 1276 2014-01-15 13:40:41Z heinze
138! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
139!
140! 1257 2013-11-08 15:18:40Z raasch
141! openACC "kernels do" replaced by "kernels loop", "loop independent" added
142!
143! 1036 2012-10-22 13:43:42Z raasch
144! code put under GPL (PALM 3.9)
145!
146! 1015 2012-09-27 09:23:24Z raasch
147! OpenACC statements added
148!
149! 978 2012-08-09 08:28:32Z fricke
150! roughness length for scalar quantities z0h added
151!
152! Revision 1.1  1998/01/23 10:06:06  raasch
153! Initial revision
154!
155!
156! Description:
157! ------------
158!> Diagnostic computation of vertical fluxes in the constant flux layer from the
159!> values of the variables at grid point k=1. Three different methods are
160!> available:
161!> 1) the "old" version (most_method = 'circular') which is fast, but inaccurate
162!> 2) a Newton iteration method (most_method = 'newton'), which is accurate, but
163!>    slower
164!> 3) a method using a lookup table which is fast and accurate. Note, however,
165!>    that this method cannot be used in case of roughness heterogeneity
166!>
167!> @todo (re)move large_scale_forcing actions
168!> @todo check/optimize OpenMP directives
169!------------------------------------------------------------------------------!
170 MODULE surface_layer_fluxes_mod
171
172    USE arrays_3d,                                                             &
173        ONLY:  e, kh, nr, nrs, nrsws, ol, pt, q, ql, qr, qrs, qrsws, qs, qsws, &
174               s, shf, ss, ssws, ts, u, us, usws, v, vpt, vsws, zu, zw, z0,    &
175               z0h, z0q, drho_air_zw, rho_air_zw
176
177    USE cloud_parameters,                                                      &
178        ONLY:  l_d_cp, pt_d_t
179
180    USE constants,                                                             &
181        ONLY:  pi
182
183    USE cpulog
184
185    USE control_parameters,                                                    &
186        ONLY:  cloud_physics, constant_heatflux, constant_scalarflux,          &
187               constant_waterflux, coupling_mode, g, humidity, ibc_e_b,        &
188               ibc_pt_b, initializing_actions, kappa,                          &
189               intermediate_timestep_count,                                    &
190               intermediate_timestep_count_max, large_scale_forcing, lsf_surf, &
191               message_string, microphysics_seifert, most_method, neutral,     &
192               passive_scalar, pt_surface, q_surface, run_coupled,             &
193               surface_pressure, simulated_time, terminate_run,                &
194               urban_surface,                                                  &
195               zeta_max, zeta_min
196
197    USE indices,                                                               &
198        ONLY:  nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_s_inner,        &
199               nzb_u_inner, nzb_v_inner
200
201    USE kinds
202
203    USE pegrid
204
205    USE land_surface_model_mod,                                                &
206        ONLY:  land_surface, skip_time_do_lsm
207
208       
209
210    IMPLICIT NONE
211
212    INTEGER(iwp) ::  i              !< loop index x direction
213    INTEGER(iwp) ::  j              !< loop index y direction
214    INTEGER(iwp) ::  k              !< loop index z direction
215    INTEGER(iwp) ::  l_bnd  = 7500  !< Lookup table index of the last time step
216
217    INTEGER(iwp), PARAMETER     :: num_steps = 15000  !< number of steps in the lookup table
218
219    LOGICAL      ::  coupled_run  !< Flag for coupled atmosphere-ocean runs
220
221    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pt1,      & !< Potential temperature at first grid level (required for cloud_physics = .T.)
222                                             qv1,      & !< Specific humidity at first grid level (required for cloud_physics = .T.)
223                                             uv_total    !< Total velocity at first grid level
224
225    REAL(wp), DIMENSION(0:num_steps-1) :: rib_tab,  & !< Lookup table bulk Richardson number
226                                          ol_tab      !< Lookup table values of L
227
228    REAL(wp)     ::  e_s,               & !< Saturation water vapor pressure
229                     ol_max = 1.0E6_wp, & !< Maximum Obukhov length
230                     rib_max,           & !< Maximum Richardson number in lookup table
231                     rib_min,           & !< Minimum Richardson number in lookup table
232                     z_mo                 !< Height of the constant flux layer where MOST is assumed
233
234
235    SAVE
236
237    PRIVATE
238
239    PUBLIC init_surface_layer_fluxes, pt1, qv1, surface_layer_fluxes, uv_total
240
241    INTERFACE init_surface_layer_fluxes
242       MODULE PROCEDURE init_surface_layer_fluxes
243    END INTERFACE init_surface_layer_fluxes
244
245    INTERFACE surface_layer_fluxes
246       MODULE PROCEDURE surface_layer_fluxes
247    END INTERFACE surface_layer_fluxes
248
249
250 CONTAINS
251
252
253!------------------------------------------------------------------------------!
254! Description:
255! ------------
256!> Main routine to compute the surface fluxes
257!------------------------------------------------------------------------------!
258    SUBROUTINE surface_layer_fluxes
259
260       IMPLICIT NONE
261
262!
263!--    In case cloud physics is used, it is required to derive potential
264!--    temperature and specific humidity at first grid level from the fields pt
265!--    and q
266       IF ( cloud_physics )  THEN
267          CALL calc_pt_q
268       ENDIF
269
270!
271!--    First, calculate the new Obukhov length, then new friction velocity,
272!--    followed by the new scaling parameters (th*, q*, etc.), and the new
273!--    surface fluxes if required. The old routine ("circular") requires a
274!--    different order of calls as the scaling parameters from the previous time
275!--    steps are used to calculate the Obukhov length
276
277!
278!--    Depending on setting of most_method use the "old" routine
279       IF ( most_method == 'circular' )  THEN
280
281          CALL calc_scaling_parameters
282
283          CALL calc_uv_total
284
285          IF ( .NOT. neutral )  THEN
286             CALL calc_ol
287          ENDIF
288
289          CALL calc_us
290
291          CALL calc_surface_fluxes
292
293!
294!--    Use either Newton iteration or a lookup table for the bulk Richardson
295!--    number to calculate the Obukhov length
296       ELSEIF ( most_method == 'newton'  .OR.  most_method == 'lookup' )  THEN
297
298          CALL calc_uv_total
299
300          IF ( .NOT. neutral )  THEN
301             CALL calc_ol
302          ENDIF
303
304          CALL calc_us
305
306          CALL calc_scaling_parameters
307
308          CALL calc_surface_fluxes
309
310       ENDIF
311
312    END SUBROUTINE surface_layer_fluxes
313
314
315!------------------------------------------------------------------------------!
316! Description:
317! ------------
318!> Initializing actions for the surface layer routine. Basically, this involves
319!> the preparation of a lookup table for the the bulk Richardson number vs
320!> Obukhov length L when using the lookup table method.
321!------------------------------------------------------------------------------!
322    SUBROUTINE init_surface_layer_fluxes
323
324       IMPLICIT NONE
325
326       INTEGER(iwp) :: l,          & !< Index for loop to create lookup table
327                       num_steps_n   !< Number of non-stretched zeta steps
328
329       LOGICAL :: terminate_run_l = .FALSE.    !< Flag to terminate run (global)
330
331       REAL(wp), PARAMETER ::  zeta_stretch = -10.0_wp !< Start of stretching in the free convection limit
332                               
333       REAL(wp), DIMENSION(:), ALLOCATABLE :: zeta_tmp
334
335
336       REAL(wp) :: zeta_step,            & !< Increment of zeta
337                   regr      = 1.01_wp,  & !< Stretching factor of zeta_step in the free convection limit
338                   regr_old  = 1.0E9_wp, & !< Stretching factor of last iteration step
339                   z0h_min   = 0.0_wp,   & !< Minimum value of z0h to create table
340                   z0_min    = 0.0_wp      !< Minimum value of z0 to create table
341!
342!--    When cloud physics is used, arrays for storing potential temperature and
343!--    specific humidity at first grid level are required
344       IF ( cloud_physics )  THEN
345          ALLOCATE ( pt1(nysg:nyng,nxlg:nxrg) )
346          ALLOCATE ( qv1(nysg:nyng,nxlg:nxrg) )
347       ENDIF
348
349!
350!--    Allocate field for storing the horizontal velocity
351       ALLOCATE ( uv_total(nysg:nyng,nxlg:nxrg) )
352
353
354!
355!--    In case of runs with neutral statification, set Obukhov length to a
356!--    large value
357       IF ( neutral ) ol = 1.0E10_wp
358
359       IF ( most_method == 'lookup' )  THEN
360
361!
362!--       Check for roughness heterogeneity. In that case terminate run and
363!--       inform user
364          IF ( MINVAL( z0h ) /= MAXVAL( z0h )  .OR.                            &
365               MINVAL( z0  ) /= MAXVAL( z0  ) )  THEN
366             terminate_run_l = .TRUE.
367          ENDIF
368
369#if defined( __parallel )
370!
371!--       Make a logical OR for all processes. Force termiation of model if result
372!--       is TRUE
373          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
374          CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL,  &
375                              MPI_LOR, comm2d, ierr )
376#else
377          terminate_run = terminate_run_l
378#endif
379
380          IF ( terminate_run )  THEN
381             message_string = 'most_method = "lookup" cannot be used in ' //   &
382                              'combination with a prescribed roughness '  //   &
383                              'heterogeneity'
384             CALL message( 'surface_layer_fluxes', 'PA0417', 1, 2, 0, 6, 0 )
385          ENDIF
386
387          ALLOCATE(  zeta_tmp(0:num_steps-1) )
388
389!
390!--       Use the lowest possible value for z_mo
391          k    = MINVAL(nzb_s_inner)
392          z_mo = zu(k+1) - zw(k)
393
394!
395!--       Calculate z/L range from zeta_stretch to zeta_max using 90% of the
396!--       available steps (num_steps). The calculation is done with negative
397!--       values of zeta in order to simplify the stretching in the free
398!--       convection limit for the remaining 10% of steps.
399          zeta_tmp(0) = - zeta_max
400          num_steps_n = ( num_steps * 9 / 10 ) - 1
401          zeta_step   = (zeta_max - zeta_stretch) / REAL(num_steps_n)
402
403          DO l = 1, num_steps_n
404             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
405          ENDDO
406
407!
408!--       Calculate stretching factor for the free convection range
409          DO  WHILE ( ABS( (regr-regr_old) / regr_old ) > 1.0E-10_wp )
410             regr_old = regr
411             regr = ( 1.0_wp - ( -zeta_min / zeta_step ) * ( 1.0_wp - regr )   &
412                    )**( 10.0_wp / REAL(num_steps) )
413          ENDDO
414
415!
416!--       Calculate z/L range from zeta_min to zeta_stretch
417          DO l = num_steps_n+1, num_steps-1
418             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
419             zeta_step = zeta_step * regr
420          ENDDO
421
422!
423!--       Save roughness lengths to temporary variables
424          z0h_min = z0h(nys,nxl)
425          z0_min  = z0(nys,nxl)
426         
427!
428!--       Calculate lookup table for the Richardson number versus Obukhov length
429!--       The Richardson number (rib) is defined depending on the choice of
430!--       boundary conditions for temperature
431          IF ( ibc_pt_b == 1 )  THEN
432             DO l = 0, num_steps-1
433                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
434                rib_tab(l) = z_mo / ol_tab(l)  / ( LOG( z_mo / z0_min )        &
435                                                - psi_m( z_mo / ol_tab(l) )    &
436                                                + psi_m( z0_min / ol_tab(l) )  &
437                                                  )**3
438             ENDDO 
439          ELSE
440             DO l = 0, num_steps-1
441                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
442                rib_tab(l) = z_mo / ol_tab(l)  * ( LOG( z_mo / z0h_min )       &
443                                              - psi_h( z_mo / ol_tab(l) )      &
444                                              + psi_h( z0h_min / ol_tab(l) )   &
445                                            )                                  &
446                                          / ( LOG( z_mo / z0_min )             &
447                                              - psi_m( z_mo / ol_tab(l) )      &
448                                              + psi_m( z0_min / ol_tab(l) )    &
449                                            )**2
450             ENDDO
451          ENDIF
452
453!
454!--       Determine minimum values of rib in the lookup table. Set upper limit
455!--       to critical Richardson number (0.25)
456          rib_min  = MINVAL(rib_tab)
457          rib_max  = 0.25 !MAXVAL(rib_tab)
458
459          DEALLOCATE( zeta_tmp )
460       ENDIF
461
462    END SUBROUTINE init_surface_layer_fluxes
463
464
465!------------------------------------------------------------------------------!
466! Description:
467! ------------
468!> Compute the absolute value of the horizontal velocity (relative to the
469!> surface). This is required by all methods
470!------------------------------------------------------------------------------!
471    SUBROUTINE calc_uv_total
472
473       IMPLICIT NONE
474
475
476       !$OMP PARALLEL DO PRIVATE( k )
477       DO  i = nxl, nxr
478          DO  j = nys, nyn
479
480             k   = nzb_s_inner(j,i)
481             uv_total(j,i) = SQRT( ( 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1)      &
482                                         - u(k,j,i)   - u(k,j,i+1) ) )**2 +    &
483                              ( 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i)           &
484                                         - v(k,j,i)   - v(k,j+1,i) ) )**2 )
485
486!
487!--          For too small values of the local wind, MOST does not work. A
488!--          threshold value is thus set if required
489!            uv_total(j,i) = MAX(0.01_wp,uv_total(j,i))
490
491          ENDDO
492       ENDDO
493
494!
495!--    Values of uv_total need to be exchanged at the ghost boundaries
496       CALL exchange_horiz_2d( uv_total )
497
498    END SUBROUTINE calc_uv_total
499
500
501!------------------------------------------------------------------------------!
502! Description:
503! ------------
504!> Calculate the Obukhov length (L) and Richardson flux number (z/L)
505!------------------------------------------------------------------------------!
506    SUBROUTINE calc_ol
507
508       IMPLICIT NONE
509
510       INTEGER(iwp) :: iter,  & !< Newton iteration step
511                       l        !< look index
512
513       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: rib !< Bulk Richardson number
514
515       REAL(wp)     :: f,      & !< Function for Newton iteration: f = Ri - [...]/[...]^2 = 0
516                       f_d_ol, & !< Derivative of f
517                       ol_l,   & !< Lower bound of L for Newton iteration
518                       ol_m,   & !< Previous value of L for Newton iteration
519                       ol_old, & !< Previous time step value of L
520                       ol_u      !< Upper bound of L for Newton iteration
521
522       IF ( TRIM( most_method ) /= 'circular' )  THEN
523     
524          !$OMP PARALLEL DO PRIVATE( k, z_mo )
525          DO  i = nxl, nxr
526             DO  j = nys, nyn
527
528                k   = nzb_s_inner(j,i)
529                z_mo = zu(k+1) - zw(k)
530
531!
532!--             Evaluate bulk Richardson number (calculation depends on
533!--             definition based on setting of boundary conditions
534                IF ( ibc_pt_b /= 1 )  THEN
535                   IF ( humidity )  THEN
536                      rib(j,i) = g * z_mo * ( vpt(k+1,j,i) - vpt(k,j,i) )      &
537                           / ( uv_total(j,i)**2 * vpt(k+1,j,i) + 1.0E-20_wp )
538                   ELSE
539                      rib(j,i) = g * z_mo * ( pt(k+1,j,i) - pt(k,j,i) )        &
540                           / ( uv_total(j,i)**2 * pt(k+1,j,i)  + 1.0E-20_wp )
541                   ENDIF     
542                ELSE
543!
544!--                When using Neumann boundary conditions, the buoyancy flux
545!--                is required but cannot be calculated at the surface, as pt
546!--                and q are not known at the surface. Hence the values at
547!--                first grid level are used to estimate the buoyancy flux
548                   IF ( humidity )  THEN
549                      rib(j,i) = - g * z_mo * ( ( 1.0_wp + 0.61_wp             &
550                                 * q(k+1,j,i) ) * shf(j,i) + 0.61_wp           &
551                                 * pt(k+1,j,i) * qsws(j,i) ) * drho_air_zw(k)  &
552                                 / ( uv_total(j,i)**3 * vpt(k+1,j,i) * kappa**2&
553                                 + 1.0E-20_wp)
554                   ELSE
555                      rib(j,i) = - g * z_mo * shf(j,i) * drho_air_zw(k)        &
556                           / ( uv_total(j,i)**3 * pt(k+1,j,i) * kappa**2       &
557                           + 1.0E-20_wp )
558                   ENDIF
559                ENDIF 
560     
561             ENDDO
562          ENDDO
563
564       ENDIF
565
566!
567!--    Calculate the Obukhov length either using a Newton iteration
568!--    method, via a lookup table, or using the old circular way
569       IF ( TRIM( most_method ) == 'newton' )  THEN
570
571          !$OMP PARALLEL DO PRIVATE( k, z_mo )
572          DO  i = nxl, nxr
573             DO  j = nys, nyn
574
575                k   = nzb_s_inner(j,i)
576                z_mo = zu(k+1) - zw(k)
577
578!
579!--             Store current value in case the Newton iteration fails
580                ol_old = ol(j,i)
581
582!
583!--             Ensure that the bulk Richardson number and the Obukhov
584!--             lengtH have the same sign
585                IF ( rib(j,i) * ol(j,i) < 0.0_wp  .OR.                         &
586                     ABS( ol(j,i) ) == ol_max )  THEN
587                   IF ( rib(j,i) > 0.0_wp ) ol(j,i) =  0.01_wp
588                   IF ( rib(j,i) < 0.0_wp ) ol(j,i) = -0.01_wp
589                ENDIF
590!
591!--             Iteration to find Obukhov length
592                iter = 0
593                DO
594                   iter = iter + 1
595!
596!--                In case of divergence, use the value of the previous time step
597                   IF ( iter > 1000 )  THEN
598                      ol(j,i) = ol_old
599                      EXIT
600                   ENDIF
601
602                   ol_m = ol(j,i)
603                   ol_l = ol_m - 0.001_wp * ol_m
604                   ol_u = ol_m + 0.001_wp * ol_m
605
606
607                   IF ( ibc_pt_b /= 1 )  THEN
608!
609!--                   Calculate f = Ri - [...]/[...]^2 = 0
610                      f = rib(j,i) - ( z_mo / ol_m ) * ( LOG( z_mo / z0h(j,i) )&
611                                                    - psi_h( z_mo / ol_m )     &
612                                                    + psi_h( z0h(j,i) / ol_m ) &
613                                                   )                           &
614                                                 / ( LOG( z_mo / z0(j,i) )     &
615                                                    - psi_m( z_mo / ol_m )     &
616                                                    + psi_m( z0(j,i) / ol_m )  &
617                                                    )**2
618
619!
620!--                    Calculate df/dL
621                       f_d_ol = ( - ( z_mo / ol_u ) * ( LOG( z_mo / z0h(j,i) ) &
622                                                   - psi_h( z_mo / ol_u )      &
623                                                   + psi_h( z0h(j,i) / ol_u )  &
624                                                 )                             &
625                                               / ( LOG( z_mo / z0(j,i) )       &
626                                                   - psi_m( z_mo / ol_u )      &
627                                                   + psi_m( z0(j,i) / ol_u )   &
628                                                 )**2                          &
629                              + ( z_mo / ol_l ) * ( LOG( z_mo / z0h(j,i) )     &
630                                                   - psi_h( z_mo / ol_l )      &
631                                                   + psi_h( z0h(j,i) / ol_l )  &
632                                                 )                             &
633                                               / ( LOG( z_mo / z0(j,i) )       &
634                                                   - psi_m( z_mo / ol_l )      &
635                                                   + psi_m( z0(j,i) / ol_l )   &
636                                                 )**2                          &
637                                ) / ( ol_u - ol_l )
638                   ELSE
639!
640!--                   Calculate f = Ri - 1 /[...]^3 = 0
641                      f = rib(j,i) - ( z_mo / ol_m ) / ( LOG( z_mo / z0(j,i) )&
642                                                    - psi_m( z_mo / ol_m )    &
643                                                    + psi_m( z0(j,i) / ol_m ) &
644                                                       )**3
645
646!
647!--                   Calculate df/dL
648                      f_d_ol = ( - ( z_mo / ol_u ) / ( LOG( z_mo / z0(j,i) )  &
649                                                   - psi_m( z_mo / ol_u )     &
650                                                   + psi_m( z0(j,i) / ol_u )  &
651                                                 )**3                         &
652                              + ( z_mo / ol_l ) / ( LOG( z_mo / z0(j,i) )     &
653                                                   - psi_m( z_mo / ol_l )     &
654                                                   + psi_m( z0(j,i) / ol_l )  &
655                                                 )**3                         &
656                                     ) / ( ol_u - ol_l )
657                   ENDIF
658!
659!--                Calculate new L
660                   ol(j,i) = ol_m - f / f_d_ol
661
662!
663!--                Ensure that the bulk Richardson number and the Obukhov
664!--                length have the same sign and ensure convergence.
665                   IF ( ol(j,i) * ol_m < 0.0_wp )  ol(j,i) = ol_m * 0.5_wp
666
667!
668!--                If unrealistic value occurs, set L to the maximum
669!--                value that is allowed
670                   IF ( ABS( ol(j,i) ) > ol_max )  THEN
671                      ol(j,i) = ol_max
672                      EXIT
673                   ENDIF
674!
675!--                Check for convergence
676                   IF ( ABS( ( ol(j,i) - ol_m ) / ol(j,i) ) < 1.0E-4_wp )  THEN
677                      EXIT
678                   ELSE
679                      CYCLE
680                   ENDIF
681
682                ENDDO
683                       
684             ENDDO
685          ENDDO
686
687       ELSEIF ( TRIM( most_method ) == 'lookup' )  THEN
688
689          !$OMP PARALLEL DO PRIVATE( k, l, z_mo ) FIRSTPRIVATE( l_bnd ) LASTPRIVATE( l_bnd )
690          DO  i = nxl, nxr
691             DO  j = nys, nyn
692
693!
694!--             If the bulk Richardson number is outside the range of the lookup
695!--             table, set it to the exceeding threshold value
696                IF ( rib(j,i) < rib_min )  rib(j,i) = rib_min
697                IF ( rib(j,i) > rib_max )  rib(j,i) = rib_max
698
699!
700!--             Find the correct index bounds for linear interpolation. As the
701!--             Richardson number will not differ very much from time step to
702!--             time step , use the index from the last step and search in the
703!--             correct direction
704                l = l_bnd
705                IF ( rib_tab(l) - rib(j,i) > 0.0_wp )  THEN
706                   DO  WHILE ( rib_tab(l-1) - rib(j,i) > 0.0_wp  .AND.  l > 0 )
707                      l = l-1
708                   ENDDO
709                ELSE
710                   DO  WHILE ( rib_tab(l) - rib(j,i) < 0.0_wp                  &
711                              .AND.  l < num_steps-1 )
712                      l = l+1
713                   ENDDO
714                ENDIF
715                l_bnd = l
716
717!
718!--             Linear interpolation to find the correct value of z/L
719                ol(j,i) = ( ol_tab(l-1) + ( ol_tab(l) - ol_tab(l-1) )          &
720                            / (  rib_tab(l) - rib_tab(l-1) )                   &
721                            * ( rib(j,i) - rib_tab(l-1) ) )
722
723             ENDDO
724          ENDDO
725
726       ELSEIF ( TRIM( most_method ) == 'circular' )  THEN
727
728          !$OMP PARALLEL DO PRIVATE( k, z_mo )
729          DO  i = nxl, nxr
730             DO  j = nys, nyn
731
732                k   = nzb_s_inner(j,i)
733                z_mo = zu(k+1) - zw(k)
734
735                IF ( .NOT. humidity )  THEN
736                   ol(j,i) =  ( pt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g      &
737                              * ts(j,i) + 1E-30_wp )
738                ELSEIF ( cloud_physics )  THEN
739
740                   ol(j,i) =  ( vpt(k+1,j,i) * us(j,i)**2 ) / ( kappa * g      &
741                              * ( ts(j,i) + 0.61_wp * pt1(j,i) * qs(j,i)       &
742                              + 0.61_wp * qv1(j,i) * ts(j,i) - ts(j,i)         &
743                              * ql(k+1,j,i) ) + 1E-30_wp )
744                ELSE
745                   ol(j,i) =  ( vpt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g     &
746                              * ( ts(j,i) + 0.61_wp * pt(k+1,j,i) * qs(j,i)    &
747                                  + 0.61_wp * q(k+1,j,i) * ts(j,i) ) + 1E-30_wp )
748                ENDIF
749!
750!--             Limit the value range of the Obukhov length.
751!--             This is necessary for very small velocities (u,v --> 0), because
752!--             the absolute value of ol can then become very small, which in
753!--             consequence would result in very large shear stresses and very
754!--             small momentum fluxes (both are generally unrealistic).
755                IF ( ( z_mo / ( ol(j,i) + 1E-30_wp ) ) < zeta_min )            &
756                   ol(j,i) = z_mo / zeta_min
757                IF ( ( z_mo / ( ol(j,i) + 1E-30_wp ) ) > zeta_max )            &
758                   ol(j,i) = z_mo / zeta_max
759             ENDDO
760          ENDDO
761
762       ENDIF
763
764!
765!--    Values of ol at ghost point locations are needed for the evaluation
766!--    of usws and vsws.
767       CALL exchange_horiz_2d( ol )
768
769    END SUBROUTINE calc_ol
770
771!
772!-- Calculate friction velocity u*
773    SUBROUTINE calc_us
774
775       IMPLICIT NONE
776
777       !$OMP PARALLEL DO PRIVATE( k, z_mo )
778       DO  i = nxlg, nxrg
779          DO  j = nysg, nyng
780
781             k   = nzb_s_inner(j,i)+1
782             z_mo = zu(k+1) - zw(k)
783
784!
785!--          Compute u* at the scalars' grid points
786             us(j,i) = kappa * uv_total(j,i) / ( LOG( z_mo / z0(j,i) )         &
787                                          - psi_m( z_mo / ol(j,i) )            &
788                                          + psi_m( z0(j,i) / ol(j,i) ) )
789          ENDDO
790       ENDDO
791
792    END SUBROUTINE calc_us
793
794!
795!-- Calculate potential temperature and specific humidity at first grid level
796    SUBROUTINE calc_pt_q
797
798       IMPLICIT NONE
799
800       DO  i = nxlg, nxrg
801          DO  j = nysg, nyng
802             k   = nzb_s_inner(j,i)+1
803             pt1(j,i) = pt(k,j,i) + l_d_cp * pt_d_t(k) * ql(k,j,i)
804             qv1(j,i) = q(k,j,i) - ql(k,j,i)
805          ENDDO
806       ENDDO
807
808    END SUBROUTINE calc_pt_q
809
810!
811!-- Calculate the other MOST scaling parameters theta*, q*, (qr*, nr*)
812    SUBROUTINE calc_scaling_parameters
813
814       IMPLICIT NONE
815
816!
817!--    Compute theta*
818       IF ( constant_heatflux )  THEN
819
820!
821!--       For a given heat flux in the surface layer:
822          !$OMP PARALLEL DO
823          DO  i = nxlg, nxrg
824             DO  j = nysg, nyng
825                k   = nzb_s_inner(j,i)
826                ts(j,i) = -shf(j,i) * drho_air_zw(k) / ( us(j,i) + 1E-30_wp )
827!
828!--             ts must be limited, because otherwise overflow may occur in case
829!--             of us=0 when computing ol further below
830                IF ( ts(j,i) < -1.05E5_wp )  ts(j,i) = -1.0E5_wp
831                IF ( ts(j,i) >   1.0E5_wp )  ts(j,i) =  1.0E5_wp
832             ENDDO
833          ENDDO
834
835       ELSE
836!
837!--       For a given surface temperature:
838          IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
839             !$OMP PARALLEL DO
840             DO  i = nxlg, nxrg
841                DO  j = nysg, nyng
842                   k = nzb_s_inner(j,i)
843                   pt(k,j,i) = pt_surface
844                ENDDO
845             ENDDO
846          ENDIF
847
848          !$OMP PARALLEL DO PRIVATE( k, z_mo )
849          DO  i = nxlg, nxrg
850             DO  j = nysg, nyng
851
852                k   = nzb_s_inner(j,i)
853                z_mo = zu(k+1) - zw(k)
854
855                IF ( cloud_physics )  THEN
856                   ts(j,i) = kappa * ( pt1(j,i) - pt(k,j,i) )                  &
857                                     / ( LOG( z_mo / z0h(j,i) )                &
858                                         - psi_h( z_mo / ol(j,i) )             &
859                                         + psi_h( z0h(j,i) / ol(j,i) ) )
860                ELSE
861                   ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) )               &
862                                     / ( LOG( z_mo / z0h(j,i) )                &
863                                         - psi_h( z_mo / ol(j,i) )             &
864                                         + psi_h( z0h(j,i) / ol(j,i) ) )
865                ENDIF
866
867             ENDDO
868          ENDDO
869       ENDIF
870
871!
872!--    If required compute q*
873       IF ( humidity )  THEN
874          IF ( constant_waterflux )  THEN
875!
876!--          For a given water flux in the surface layer
877             !$OMP PARALLEL DO
878             DO  i = nxlg, nxrg
879                DO  j = nysg, nyng
880                   k   = nzb_s_inner(j,i)
881                   qs(j,i) = -qsws(j,i) * drho_air_zw(k) / ( us(j,i) + 1E-30_wp )
882                ENDDO
883             ENDDO
884
885          ELSE
886             coupled_run = ( coupling_mode == 'atmosphere_to_ocean'  .AND.     &
887                             run_coupled )
888
889             IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
890                !$OMP PARALLEL DO
891                DO  i = nxlg, nxrg
892                   DO  j = nysg, nyng
893                      k = nzb_s_inner(j,i)
894                      q(k,j,i) = q_surface
895                   ENDDO
896                ENDDO
897             ENDIF
898
899             !$OMP PARALLEL DO PRIVATE( e_s, k, z_mo )
900             DO  i = nxlg, nxrg
901                DO  j = nysg, nyng
902
903                   k   = nzb_s_inner(j,i)
904                   z_mo = zu(k+1) - zw(k)
905
906!
907!--                Assume saturation for atmosphere coupled to ocean (but not
908!--                in case of precursor runs)
909                   IF ( coupled_run )  THEN
910                      e_s = 6.1_wp * &
911                              EXP( 0.07_wp * ( MIN(pt(k,j,i),pt(k+1,j,i))      &
912                                               - 273.15_wp ) )
913                      q(k,j,i) = 0.622_wp * e_s / ( surface_pressure - e_s )
914                   ENDIF
915
916                   IF ( cloud_physics )  THEN
917                      qs(j,i) = kappa * ( qv1(j,i) - q(k,j,i) )                &
918                                        / ( LOG( z_mo / z0q(j,i) )             &
919                                            - psi_h( z_mo / ol(j,i) )          &
920                                            + psi_h( z0q(j,i) / ol(j,i) ) )
921
922                   ELSE
923                      qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) )              &
924                                        / ( LOG( z_mo / z0q(j,i) )             &
925                                            - psi_h( z_mo / ol(j,i) )          &
926                                            + psi_h( z0q(j,i) / ol(j,i) ) )
927                   ENDIF
928
929                ENDDO
930             ENDDO
931          ENDIF
932       ENDIF
933       
934!
935!--    If required compute s*
936       IF ( passive_scalar )  THEN
937          IF ( constant_scalarflux )  THEN
938!
939!--          For a given water flux in the surface layer
940             !$OMP PARALLEL DO
941             DO  i = nxlg, nxrg
942                DO  j = nysg, nyng
943                   ss(j,i) = -ssws(j,i) / ( us(j,i) + 1E-30_wp )
944                ENDDO
945             ENDDO
946          ENDIF
947       ENDIF
948
949
950!
951!--    If required compute qr* and nr*
952       IF ( cloud_physics  .AND.  microphysics_seifert )   &
953       THEN
954
955          !$OMP PARALLEL DO PRIVATE( k, z_mo )
956          DO  i = nxlg, nxrg
957             DO  j = nysg, nyng
958
959                k   = nzb_s_inner(j,i)
960                z_mo = zu(k+1) - zw(k)
961
962                qrs(j,i) = kappa * ( qr(k+1,j,i) - qr(k,j,i) )              &
963                                 / ( LOG( z_mo / z0q(j,i) )                 &
964                                     - psi_h( z_mo / ol(j,i) )              &
965                                     + psi_h( z0q(j,i) / ol(j,i) ) )
966
967                nrs(j,i) = kappa * ( nr(k+1,j,i) - nr(k,j,i) )              &
968                                 / ( LOG( z_mo / z0q(j,i) )                 &
969                                     - psi_h( z_mo / ol(j,i) )              &
970                                     + psi_h( z0q(j,i) / ol(j,i) ) )
971             ENDDO
972          ENDDO
973
974       ENDIF
975
976    END SUBROUTINE calc_scaling_parameters
977
978
979
980!
981!-- Calculate surface fluxes usws, vsws, shf, qsws, (qrsws, nrsws)
982    SUBROUTINE calc_surface_fluxes
983
984       IMPLICIT NONE
985
986       REAL(wp) :: ol_mid !< Grid-interpolated L
987
988!
989!--    Compute u'w' for the total model domain.
990!--    First compute the corresponding component of u* and square it.
991       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
992       DO  i = nxl, nxr
993          DO  j = nys, nyn
994
995             k   = nzb_u_inner(j,i)
996             z_mo = zu(k+1) - zw(k)
997!
998!--          Compute bulk Obukhov length for this point
999             ol_mid = 0.5_wp * ( ol(j,i-1) + ol(j,i) )
1000
1001             IF ( ol_mid == 0.0_wp )  THEN
1002                ol_mid = MIN(ol(j,i-1), ol(j,i))
1003             ENDIF
1004
1005             usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) )                     &
1006                                 / ( LOG( z_mo / z0(j,i) )                     &
1007                                     - psi_m( z_mo / ol_mid )                  &
1008                                     + psi_m( z0(j,i) / ol_mid ) )
1009
1010             usws(j,i) = -usws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) )         &
1011                                    * rho_air_zw(k)
1012          ENDDO
1013       ENDDO
1014
1015!
1016!--    Compute v'w' for the total model domain.
1017!--    First compute the corresponding component of u* and square it.
1018       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
1019       DO  i = nxl, nxr
1020          DO  j = nys, nyn
1021
1022             k   = nzb_v_inner(j,i)
1023             z_mo = zu(k+1) - zw(k)
1024!
1025!--          Compute bulk Obukhov length for this point
1026             ol_mid = 0.5_wp * ( ol(j-1,i) + ol(j,i) )
1027
1028             IF ( ol_mid == 0.0_wp )  THEN
1029                ol_mid = MIN(ol(j-1,i), ol(j-1,i))
1030             ENDIF
1031
1032             vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) )                     &
1033                                 / ( LOG( z_mo / z0(j,i) )                     &
1034                                     - psi_m( z_mo / ol_mid )                  &
1035                                     + psi_m( z0(j,i) / ol_mid ) )
1036
1037             vsws(j,i) = -vsws(j,i) * 0.5_wp * ( us(j-1,i) + us(j,i) )         &
1038                                    * rho_air_zw(k)
1039
1040          ENDDO
1041       ENDDO
1042
1043!
1044!--    Exchange the boundaries for the momentum fluxes (is this still required?)
1045       CALL exchange_horiz_2d( usws )
1046       CALL exchange_horiz_2d( vsws )
1047
1048!
1049!--    Compute the vertical kinematic heat flux
1050       IF (  .NOT.  constant_heatflux  .AND.  ( simulated_time <=            &
1051            skip_time_do_lsm  .OR.  .NOT.  land_surface )  .AND.             &
1052            .NOT.  urban_surface )  THEN
1053          !$OMP PARALLEL DO
1054          DO  i = nxlg, nxrg
1055             DO  j = nysg, nyng
1056                k   = nzb_s_inner(j,i)
1057                shf(j,i) = -ts(j,i) * us(j,i) * rho_air_zw(k)
1058             ENDDO
1059          ENDDO
1060
1061       ENDIF
1062
1063!
1064!--    Compute the vertical water flux
1065       IF (  .NOT.  constant_waterflux  .AND.  humidity  .AND.                 &
1066             ( simulated_time <= skip_time_do_lsm                              &
1067            .OR.  .NOT.  land_surface ) )  THEN
1068          !$OMP PARALLEL DO
1069          DO  i = nxlg, nxrg
1070             DO  j = nysg, nyng
1071                k   = nzb_s_inner(j,i)
1072                qsws(j,i) = -qs(j,i) * us(j,i) * rho_air_zw(k)
1073             ENDDO
1074          ENDDO
1075
1076       ENDIF
1077       
1078!
1079!--    Compute the vertical scalar flux
1080       IF (  .NOT.  constant_scalarflux  .AND.  passive_scalar  .AND.          &
1081             ( simulated_time <= skip_time_do_lsm                              &
1082            .OR.  .NOT.  land_surface ) )  THEN
1083          !$OMP PARALLEL DO
1084          DO  i = nxlg, nxrg
1085             DO  j = nysg, nyng
1086                ssws(j,i) = -ss(j,i) * us(j,i)
1087             ENDDO
1088          ENDDO
1089
1090       ENDIF       
1091
1092!
1093!--    Compute (turbulent) fluxes of rain water content and rain drop conc.
1094       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
1095          !$OMP PARALLEL DO
1096          DO  i = nxlg, nxrg
1097             DO  j = nysg, nyng
1098                qrsws(j,i) = -qrs(j,i) * us(j,i)
1099                nrsws(j,i) = -nrs(j,i) * us(j,i)
1100             ENDDO
1101          ENDDO
1102       ENDIF
1103
1104!
1105!--    Bottom boundary condition for the TKE
1106       IF ( ibc_e_b == 2 )  THEN
1107          !$OMP PARALLEL DO
1108          DO  i = nxlg, nxrg
1109             DO  j = nysg, nyng
1110                k = nzb_s_inner(j,i)
1111                e(k+1,j,i) = ( us(j,i) / 0.1_wp )**2
1112!
1113!--             As a test: cm = 0.4
1114!               e(k+1,j,i) = ( us(j,i) / 0.4_wp )**2
1115                e(k,j,i)   = e(k+1,j,i)
1116             ENDDO
1117          ENDDO
1118       ENDIF
1119
1120    END SUBROUTINE calc_surface_fluxes
1121
1122
1123!
1124!-- Integrated stability function for momentum
1125    FUNCTION psi_m( zeta ) 
1126       
1127       USE kinds
1128
1129       IMPLICIT NONE
1130
1131       REAL(wp)            :: psi_m !< Integrated similarity function result
1132       REAL(wp)            :: zeta  !< Stability parameter z/L
1133       REAL(wp)            :: x     !< dummy variable
1134
1135       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
1136       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
1137       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
1138       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
1139       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
1140       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
1141
1142
1143       IF ( zeta < 0.0_wp )  THEN
1144          x = SQRT( SQRT( 1.0_wp  - 16.0_wp * zeta ) )
1145          psi_m = pi * 0.5_wp - 2.0_wp * ATAN( x ) + LOG( ( 1.0_wp + x )**2    &
1146                  * ( 1.0_wp + x**2 ) * 0.125_wp )
1147       ELSE
1148
1149          psi_m = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - a * zeta         &
1150                   - bc_d_d
1151!
1152!--       Old version for stable conditions (only valid for z/L < 0.5)
1153!--       psi_m = - 5.0_wp * zeta
1154
1155       ENDIF
1156
1157    END FUNCTION psi_m
1158
1159
1160!
1161!-- Integrated stability function for heat and moisture
1162    FUNCTION psi_h( zeta ) 
1163       
1164       USE kinds
1165
1166       IMPLICIT NONE
1167
1168       REAL(wp)            :: psi_h !< Integrated similarity function result
1169       REAL(wp)            :: zeta  !< Stability parameter z/L
1170       REAL(wp)            :: x     !< dummy variable
1171
1172       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
1173       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
1174       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
1175       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
1176       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
1177       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
1178
1179
1180       IF ( zeta < 0.0_wp )  THEN
1181          x = SQRT( 1.0_wp  - 16.0_wp * zeta )
1182          psi_h = 2.0_wp * LOG( (1.0_wp + x ) / 2.0_wp )
1183       ELSE
1184          psi_h = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - (1.0_wp          &
1185                  + 0.66666666666_wp * a * zeta )**1.5_wp - bc_d_d             &
1186                  + 1.0_wp
1187!
1188!--       Old version for stable conditions (only valid for z/L < 0.5)
1189!--       psi_h = - 5.0_wp * zeta
1190       ENDIF
1191
1192    END FUNCTION psi_h
1193
1194 END MODULE surface_layer_fluxes_mod
Note: See TracBrowser for help on using the repository browser.