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

Last change on this file since 2699 was 2696, checked in by kanani, 7 years ago

Merge of branch palm4u into trunk

  • Property svn:keywords set to Id
File size: 83.4 KB
Line 
1!> @file surface_layer_fluxes_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
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!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: surface_layer_fluxes_mod.f90 2696 2017-12-14 17:12:51Z kanani $
28! - Implementation of chemistry module (FK)
29! - Added calculation of pt1 and qv1 for all surface types. Added calculation of
30!   pt_surface for default-type surfaces (BM)
31! - Add flag to disable computation of qsws in case of urban surface (MS)
32!
33! 2547 2017-10-16 12:41:56Z schwenkel
34! extended by cloud_droplets option
35!
36! 2321 2017-07-24 15:57:07Z schwenkel
37! Bugfix: Correct index in lookup table for Obukhov length
38!
39! 2299 2017-06-29 10:14:38Z suehring
40! Adjusted for allow separate spinups of LSM and atmosphere code
41!
42! 2292 2017-06-20 09:51:42Z schwenkel
43! Implementation of new microphysic scheme: cloud_scheme = 'morrison'
44! includes two more prognostic equations for cloud drop concentration (nc) 
45! and cloud water content (qc).
46!
47! 2281 2017-06-13 11:34:50Z suehring
48! Clean-up unnecessary index access to surface type
49!
50! 2233 2017-05-30 18:08:54Z suehring
51!
52! 2232 2017-05-30 17:47:52Z suehring
53! Adjustments to new surface concept
54! OpenMP bugfix
55!
56! 2118 2017-01-17 16:38:49Z raasch
57! OpenACC directives and related code removed
58!
59! 2091 2016-12-21 16:38:18Z suehring
60! Bugfix in calculation of vsws ( incorrect linear interpolation of us )
61!
62! 2076 2016-12-02 13:54:20Z raasch
63! further openmp bugfix for lookup method
64!
65! 2073 2016-11-30 14:34:05Z raasch
66! openmp bugfix for lookup method
67!
68! 2037 2016-10-26 11:15:40Z knoop
69! Anelastic approximation implemented
70!
71! 2011 2016-09-19 17:29:57Z kanani
72! Flag urban_surface is now defined in module control_parameters.
73!
74! 2007 2016-08-24 15:47:17Z kanani
75! Account for urban surface model in computation of vertical kinematic heatflux
76!
77! 2000 2016-08-20 18:09:15Z knoop
78! Forced header and separation lines into 80 columns
79!
80! 1992 2016-08-12 15:14:59Z suehring
81! Minor bug, declaration of look-up index as INTEGER
82!
83! 1960 2016-07-12 16:34:24Z suehring
84! Treat humidity and passive scalar separately
85!
86! 1929 2016-06-09 16:25:25Z suehring
87! Bugfix: avoid segmentation fault in case one grid point is horizontally
88! completely surrounded by topography
89!
90! 1920 2016-05-30 10:50:15Z suehring
91! Avoid segmentation fault (see change in 1915) by different initialization of
92! us instead of adding a very small number in the denominator
93!
94! 1915 2016-05-27 11:05:02Z suehring
95! Bugfix: avoid segmentation fault in case of most_method = 'circular' at first
96! timestep
97!
98! 1850 2016-04-08 13:29:27Z maronga
99! Module renamed
100!
101!
102! 1822 2016-04-07 07:49:42Z hoffmann
103! icloud_scheme replaced by microphysics_*
104!
105! 1788 2016-03-10 11:01:04Z maronga
106! Added parameter z0q which replaces z0h in the similarity functions for
107! humidity.
108! Syntax layout improved.
109!
110! 1757 2016-02-22 15:49:32Z maronga
111! Minor fixes.
112!
113! 1749 2016-02-09 12:19:56Z raasch
114! further OpenACC adjustments
115!
116! 1747 2016-02-08 12:25:53Z raasch
117! adjustments for OpenACC usage
118!
119! 1709 2015-11-04 14:47:01Z maronga
120! Bugfix: division by zero could occur when calculating rib at low wind speeds
121! Bugfix: calculation of uv_total for neutral = .T., initial value for ol for
122! neutral = .T.
123!
124! 1705 2015-11-02 14:28:56Z maronga
125! Typo removed
126!
127! 1697 2015-10-28 17:14:10Z raasch
128! FORTRAN and OpenMP errors removed
129!
130! 1696 2015-10-27 10:03:34Z maronga
131! Modularized and completely re-written version of prandtl_fluxes.f90. In the
132! course of the re-writing two additional methods have been implemented. See
133! updated description.
134!
135! 1551 2015-03-03 14:18:16Z maronga
136! Removed land surface model part. The surface fluxes are now always calculated
137! within prandtl_fluxes, based on the given surface temperature/humidity (which
138! is either provided by the land surface model, by large scale forcing data, or
139! directly prescribed by the user.
140!
141! 1496 2014-12-02 17:25:50Z maronga
142! Adapted for land surface model
143!
144! 1494 2014-11-21 17:14:03Z maronga
145! Bugfixes: qs is now calculated before calculation of Rif. calculation of
146! buoyancy flux in Rif corrected (added missing humidity term), allow use of
147! topography for coupled runs (not tested)
148!
149! 1361 2014-04-16 15:17:48Z hoffmann
150! Bugfix: calculation of turbulent fluxes of rain water content (qrsws) and rain
151! drop concentration (nrsws) added
152!
153! 1340 2014-03-25 19:45:13Z kanani
154! REAL constants defined as wp-kind
155!
156! 1320 2014-03-20 08:40:49Z raasch
157! ONLY-attribute added to USE-statements,
158! kind-parameters added to all INTEGER and REAL declaration statements,
159! kinds are defined in new module kinds,
160! old module precision_kind is removed,
161! revision history before 2012 removed,
162! comment fields (!:) to be used for variable explanations added to
163! all variable declaration statements
164!
165! 1276 2014-01-15 13:40:41Z heinze
166! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
167!
168! 1257 2013-11-08 15:18:40Z raasch
169! openACC "kernels do" replaced by "kernels loop", "loop independent" added
170!
171! 1036 2012-10-22 13:43:42Z raasch
172! code put under GPL (PALM 3.9)
173!
174! 1015 2012-09-27 09:23:24Z raasch
175! OpenACC statements added
176!
177! 978 2012-08-09 08:28:32Z fricke
178! roughness length for scalar quantities z0h added
179!
180! Revision 1.1  1998/01/23 10:06:06  raasch
181! Initial revision
182!
183!
184! Description:
185! ------------
186!> Diagnostic computation of vertical fluxes in the constant flux layer from the
187!> values of the variables at grid point k=1. Three different methods are
188!> available:
189!> 1) the "old" version (most_method = 'circular') which is fast, but inaccurate
190!> 2) a Newton iteration method (most_method = 'newton'), which is accurate, but
191!>    slower
192!> 3) a method using a lookup table which is fast and accurate. Note, however,
193!>    that this method cannot be used in case of roughness heterogeneity
194!>
195!> @todo (re)move large_scale_forcing actions
196!> @todo check/optimize OpenMP directives
197!> @todo simplify if conditions (which flux need to be computed in which case)
198!------------------------------------------------------------------------------!
199 MODULE surface_layer_fluxes_mod
200
201    USE arrays_3d,                                                             &
202        ONLY:  e, kh, nc, nr, pt, q, ql, qc, qr, s, u, v, vpt, w, zu, zw,      &
203               drho_air_zw, rho_air_zw
204
205#if defined( __chem )
206    USE chem_modules,                                                          &
207        ONLY:  constant_csflux, nvar
208#endif
209
210    USE cloud_parameters,                                                      &
211        ONLY:  l_d_cp, pt_d_t
212
213    USE constants,                                                             &
214        ONLY:  pi
215
216    USE cpulog
217
218    USE control_parameters,                                                    &
219        ONLY:  air_chemistry, cloud_droplets, cloud_physics,                   &
220               constant_heatflux, constant_scalarflux,                         &     
221               constant_waterflux, coupling_mode, g, humidity, ibc_e_b,        &
222               ibc_pt_b, initializing_actions, kappa,                          &
223               intermediate_timestep_count, intermediate_timestep_count_max,   &
224               land_surface, large_scale_forcing, lsf_surf,                    &
225               message_string, microphysics_morrison, microphysics_seifert,    &
226               most_method, neutral, passive_scalar, pt_surface, q_surface,    &
227               run_coupled, surface_pressure, simulated_time, terminate_run,   &
228               time_since_reference_point, urban_surface, zeta_max, zeta_min
229
230    USE grid_variables,                                                        &
231        ONLY:  dx, dy 
232
233    USE indices,                                                               &
234        ONLY:  nxl, nxr, nys, nyn, nzb
235
236    USE kinds
237
238    USE pegrid
239
240    USE land_surface_model_mod,                                                &
241        ONLY:  aero_resist_kray, skip_time_do_lsm
242
243    USE surface_mod,                                                           &
244        ONLY :  surf_def_h, surf_def_v, surf_lsm_h, surf_lsm_v, surf_type,     &
245                surf_usm_h, surf_usm_v
246       
247
248    IMPLICIT NONE
249
250    INTEGER(iwp) ::  i              !< loop index x direction
251    INTEGER(iwp) ::  j              !< loop index y direction
252    INTEGER(iwp) ::  k              !< loop index z direction
253    INTEGER(iwp) ::  l              !< loop index for surf type
254    INTEGER(iwp) ::  li_bnd  = 7500 !< Lookup table index of the last time step
255
256    INTEGER(iwp), PARAMETER ::  num_steps = 15000  !< number of steps in the lookup table
257
258    LOGICAL      ::  coupled_run       !< Flag for coupled atmosphere-ocean runs
259    LOGICAL      ::  downward = .FALSE.!< Flag indicating downward-facing horizontal surface
260    LOGICAL      ::  mom_uv  = .FALSE. !< Flag indicating calculation of usvs and vsus at vertical surfaces
261    LOGICAL      ::  mom_w   = .FALSE. !< Flag indicating calculation of wsus and wsvs at vertical surfaces
262    LOGICAL      ::  mom_tke = .FALSE. !< Flag indicating calculation of momentum fluxes at vertical surfaces used for TKE production
263    LOGICAL      ::  surf_vertical     !< Flag indicating vertical surfaces
264
265    REAL(wp), DIMENSION(0:num_steps-1) :: rib_tab,  & !< Lookup table bulk Richardson number
266                                          ol_tab      !< Lookup table values of L
267
268    REAL(wp)     ::  e_s,               & !< Saturation water vapor pressure
269                     ol_max = 1.0E6_wp, & !< Maximum Obukhov length
270                     rib_max,           & !< Maximum Richardson number in lookup table
271                     rib_min,           & !< Minimum Richardson number in lookup table
272                     z_mo                 !< Height of the constant flux layer where MOST is assumed
273
274    TYPE(surf_type), POINTER ::  surf     !< surf-type array, used to generalize subroutines
275
276
277    SAVE
278
279    PRIVATE
280
281    PUBLIC init_surface_layer_fluxes, surface_layer_fluxes
282
283    INTERFACE init_surface_layer_fluxes
284       MODULE PROCEDURE init_surface_layer_fluxes
285    END INTERFACE init_surface_layer_fluxes
286
287    INTERFACE surface_layer_fluxes
288       MODULE PROCEDURE surface_layer_fluxes
289    END INTERFACE surface_layer_fluxes
290
291
292 CONTAINS
293
294
295!------------------------------------------------------------------------------!
296! Description:
297! ------------
298!> Main routine to compute the surface fluxes
299!------------------------------------------------------------------------------!
300    SUBROUTINE surface_layer_fluxes
301
302       IMPLICIT NONE
303
304       surf_vertical = .FALSE.
305       downward      = .FALSE.
306!
307!--    Derive potential temperature and specific humidity at first grid level
308!--    from the fields pt and q
309!
310!--    First call for horizontal default-type surfaces (l=0 - upward facing,
311!--    l=1 - downward facing)
312       DO  l = 0, 1
313          IF ( surf_def_h(l)%ns >= 1  )  THEN
314             surf => surf_def_h(l)
315             CALL calc_pt_q
316             IF ( .NOT. neutral )  CALL calc_pt_surface
317          ENDIF
318       ENDDO
319!
320!--    Call for natural-type horizontal surfaces
321       IF ( surf_lsm_h%ns >= 1  )  THEN
322          surf => surf_lsm_h
323          CALL calc_pt_q
324       ENDIF
325
326!
327!--    Call for urban-type horizontal surfaces
328       IF ( surf_usm_h%ns >= 1  )  THEN
329          surf => surf_usm_h
330          CALL calc_pt_q
331       ENDIF
332
333!
334!--    Call for natural-type vertical surfaces
335       DO  l = 0, 3
336          IF ( surf_lsm_v(l)%ns >= 1  )  THEN
337             surf => surf_lsm_v(l)
338             CALL calc_pt_q
339          ENDIF
340
341!
342!--    Call for urban-type vertical surfaces
343          IF ( surf_usm_v(l)%ns >= 1  )  THEN
344             surf => surf_usm_v(l)
345             CALL calc_pt_q
346          ENDIF
347       ENDDO
348
349!
350!--    First, calculate the new Obukhov length, then new friction velocity,
351!--    followed by the new scaling parameters (th*, q*, etc.), and the new
352!--    surface fluxes if required. The old routine ("circular") requires a
353!--    different order of calls as the scaling parameters from the previous time
354!--    steps are used to calculate the Obukhov length
355
356!
357!--    Depending on setting of most_method use the "old" routine
358!--    Note, each routine is called for different surface types.
359!--    First call for default-type horizontal surfaces, for natural- and
360!--    urban-type surfaces. Note, at this place only upward-facing horizontal
361!--    surfaces are treted.
362       IF ( most_method == 'circular' )  THEN
363!
364!--       Default-type upward-facing horizontal surfaces
365          IF ( surf_def_h(0)%ns >= 1  )  THEN
366             surf => surf_def_h(0)
367             CALL calc_scaling_parameters
368             CALL calc_uvw_abs
369             IF ( .NOT. neutral )  CALL calc_ol
370             CALL calc_us
371             CALL calc_surface_fluxes
372          ENDIF
373!
374!--       Natural-type horizontal surfaces
375          IF ( surf_lsm_h%ns >= 1  )  THEN
376             surf => surf_lsm_h
377             CALL calc_scaling_parameters
378             CALL calc_uvw_abs
379             IF ( .NOT. neutral )  CALL calc_ol
380             CALL calc_us
381             CALL calc_surface_fluxes
382          ENDIF
383!
384!--       Urban-type horizontal surfaces
385          IF ( surf_usm_h%ns >= 1  )  THEN
386             surf => surf_usm_h
387             CALL calc_scaling_parameters
388             CALL calc_uvw_abs
389             IF ( .NOT. neutral )  CALL calc_ol
390             CALL calc_us
391             CALL calc_surface_fluxes
392          ENDIF
393!
394!--    Use either Newton iteration or a lookup table for the bulk Richardson
395!--    number to calculate the Obukhov length
396       ELSEIF ( most_method == 'newton'  .OR.  most_method == 'lookup' )  THEN
397!
398!--       Default-type upward-facing horizontal surfaces
399          IF ( surf_def_h(0)%ns >= 1  )  THEN
400             surf => surf_def_h(0)
401             CALL calc_uvw_abs
402             IF ( .NOT. neutral )  CALL calc_ol
403             CALL calc_us
404             CALL calc_scaling_parameters
405             CALL calc_surface_fluxes
406          ENDIF
407!
408!--       Natural-type horizontal surfaces
409          IF ( surf_lsm_h%ns >= 1  )  THEN
410             surf => surf_lsm_h
411             CALL calc_uvw_abs
412             IF ( .NOT. neutral )  CALL calc_ol
413             CALL calc_us
414             CALL calc_scaling_parameters
415             CALL calc_surface_fluxes
416          ENDIF
417!
418!--       Urban-type horizontal surfaces
419          IF ( surf_usm_h%ns >= 1  )  THEN
420             surf => surf_usm_h
421             CALL calc_uvw_abs
422             IF ( .NOT. neutral )  CALL calc_ol
423             CALL calc_us
424             CALL calc_scaling_parameters
425             CALL calc_surface_fluxes
426          ENDIF
427
428       ENDIF
429!
430!--    Treat downward-facing horizontal surfaces. Note, so far, these are
431!--    always default type. Stratification is not considered
432!--    in this case, hence, no further distinction between different
433!--    most_method is required. 
434       IF ( surf_def_h(1)%ns >= 1  )  THEN
435          downward = .TRUE.
436          surf => surf_def_h(1)
437          CALL calc_uvw_abs
438          CALL calc_us
439          CALL calc_surface_fluxes
440          downward = .FALSE.
441       ENDIF
442!
443!--    Calculate surfaces fluxes at vertical surfaces for momentum
444!--    and subgrid-scale TKE.
445!--    No stability is considered. Therefore, scaling parameters and Obukhov-
446!--    length do not need to be calculated and no distinction in 'circular',
447!--    'Newton' or 'lookup' is necessary so far.
448!--    Note, this will change if stability is once considered.
449       surf_vertical = .TRUE.
450!
451!--    Calculate horizontal momentum fluxes at north- and south-facing
452!--    surfaces(usvs).
453!--    For default-type surfaces
454       mom_uv = .TRUE. 
455       DO  l = 0, 1
456          IF ( surf_def_v(l)%ns >= 1  )  THEN
457             surf => surf_def_v(l)
458!
459!--          Compute surface-parallel velocity
460             CALL calc_uvw_abs_v_ugrid
461!
462!--          Compute respective friction velocity on staggered grid
463             CALL calc_us
464!
465!--          Compute respective surface fluxes for momentum and TKE
466             CALL calc_surface_fluxes
467          ENDIF
468       ENDDO
469!
470!--    For natural-type surfaces. Please note, even though stability is not
471!--    considered for the calculation of momentum fluxes at vertical surfaces,
472!--    scaling parameters and Obukov length are calculated nevertheless in this
473!--    case. This is due to the requirement of ts in parameterization of heat
474!--    flux in land-surface model in case of aero_resist_kray is not true.
475       IF ( .NOT. aero_resist_kray )  THEN
476          IF ( most_method == 'circular' )  THEN
477             DO  l = 0, 1
478                IF ( surf_lsm_v(l)%ns >= 1  )  THEN
479                   surf => surf_lsm_v(l)
480!
481!--                Compute scaling parameters
482                   CALL calc_scaling_parameters
483!
484!--                Compute surface-parallel velocity
485                   CALL calc_uvw_abs_v_ugrid
486!
487!--                Compute Obukhov length
488                   IF ( .NOT. neutral )  CALL calc_ol
489!
490!--                Compute respective friction velocity on staggered grid
491                   CALL calc_us
492!
493!--                Compute respective surface fluxes for momentum and TKE
494                   CALL calc_surface_fluxes
495                ENDIF
496             ENDDO
497          ELSE
498             DO  l = 0, 1
499                IF ( surf_lsm_v(l)%ns >= 1  )  THEN
500                   surf => surf_lsm_v(l)
501!
502!--                Compute surface-parallel velocity
503                   CALL calc_uvw_abs_v_ugrid
504!
505!--                Compute Obukhov length
506                   IF ( .NOT. neutral )  CALL calc_ol
507!
508!--                Compute respective friction velocity on staggered grid
509                   CALL calc_us
510!
511!--                Compute scaling parameters
512                   CALL calc_scaling_parameters
513!
514!--                Compute respective surface fluxes for momentum and TKE
515                   CALL calc_surface_fluxes
516                ENDIF
517             ENDDO
518          ENDIF
519!
520!--    No ts is required, so scaling parameters and Obukhov length do not need
521!--    to be computed.
522       ELSE
523          DO  l = 0, 1
524             IF ( surf_lsm_v(l)%ns >= 1  )  THEN
525                surf => surf_lsm_v(l)
526!   
527!--             Compute surface-parallel velocity
528                CALL calc_uvw_abs_v_ugrid
529!
530!--             Compute respective friction velocity on staggered grid
531                CALL calc_us
532!
533!--             Compute respective surface fluxes for momentum and TKE
534                CALL calc_surface_fluxes
535             ENDIF
536          ENDDO
537       ENDIF
538!
539!--    For urban-type surfaces
540       DO  l = 0, 1
541          IF ( surf_usm_v(l)%ns >= 1  )  THEN
542             surf => surf_usm_v(l)
543!
544!--          Compute surface-parallel velocity
545             CALL calc_uvw_abs_v_ugrid
546!
547!--          Compute respective friction velocity on staggered grid
548             CALL calc_us
549!
550!--          Compute respective surface fluxes for momentum and TKE
551             CALL calc_surface_fluxes
552          ENDIF
553       ENDDO
554!
555!--    Calculate horizontal momentum fluxes at east- and west-facing
556!--    surfaces (vsus).
557!--    For default-type surfaces
558       DO  l = 2, 3
559          IF ( surf_def_v(l)%ns >= 1  )  THEN
560             surf => surf_def_v(l)
561!
562!--          Compute surface-parallel velocity
563             CALL calc_uvw_abs_v_vgrid
564!
565!--          Compute respective friction velocity on staggered grid
566             CALL calc_us
567!
568!--          Compute respective surface fluxes for momentum and TKE
569             CALL calc_surface_fluxes
570          ENDIF
571       ENDDO
572!
573!--    For natural-type surfaces. Please note, even though stability is not
574!--    considered for the calculation of momentum fluxes at vertical surfaces,
575!--    scaling parameters and Obukov length are calculated nevertheless in this
576!--    case. This is due to the requirement of ts in parameterization of heat
577!--    flux in land-surface model in case of aero_resist_kray is not true.
578       IF ( .NOT. aero_resist_kray )  THEN
579          IF ( most_method == 'circular' )  THEN
580             DO  l = 2, 3
581                IF ( surf_lsm_v(l)%ns >= 1  )  THEN
582                   surf => surf_lsm_v(l)
583!
584!--                Compute scaling parameters
585                   CALL calc_scaling_parameters
586!
587!--                Compute surface-parallel velocity
588                   CALL calc_uvw_abs_v_vgrid
589!
590!--                Compute Obukhov length
591                   IF ( .NOT. neutral )  CALL calc_ol
592!
593!--                Compute respective friction velocity on staggered grid
594                   CALL calc_us
595!
596!--                Compute respective surface fluxes for momentum and TKE
597                   CALL calc_surface_fluxes
598                ENDIF
599             ENDDO
600          ELSE
601             DO  l = 2, 3
602                IF ( surf_lsm_v(l)%ns >= 1  )  THEN
603                   surf => surf_lsm_v(l)
604!
605!--                Compute surface-parallel velocity
606                   CALL calc_uvw_abs_v_vgrid
607!
608!--                Compute Obukhov length
609                   IF ( .NOT. neutral )  CALL calc_ol
610!
611!--                Compute respective friction velocity on staggered grid
612                   CALL calc_us
613!
614!--                Compute scaling parameters
615                   CALL calc_scaling_parameters
616!
617!--                Compute respective surface fluxes for momentum and TKE
618                   CALL calc_surface_fluxes
619                ENDIF
620             ENDDO
621          ENDIF
622       ELSE
623          DO  l = 2, 3
624             IF ( surf_lsm_v(l)%ns >= 1  )  THEN
625                surf => surf_lsm_v(l)
626!   
627!--             Compute surface-parallel velocity
628                CALL calc_uvw_abs_v_vgrid
629!
630!--             Compute respective friction velocity on staggered grid
631                CALL calc_us
632!
633!--             Compute respective surface fluxes for momentum and TKE
634                CALL calc_surface_fluxes
635             ENDIF
636          ENDDO
637       ENDIF
638!
639!--    For urban-type surfaces
640       DO  l = 2, 3
641          IF ( surf_usm_v(l)%ns >= 1  )  THEN
642             surf => surf_usm_v(l)
643!
644!--          Compute surface-parallel velocity
645             CALL calc_uvw_abs_v_vgrid
646!
647!--          Compute respective friction velocity on staggered grid
648             CALL calc_us
649!
650!--          Compute respective surface fluxes for momentum and TKE
651             CALL calc_surface_fluxes
652          ENDIF
653       ENDDO
654       mom_uv = .FALSE.
655!
656!--    Calculate horizontal momentum fluxes of w (wsus and wsvs) at vertial
657!--    surfaces.
658       mom_w = .TRUE.
659!
660!--    Default-type surfaces
661       DO  l = 0, 3
662          IF ( surf_def_v(l)%ns >= 1  )  THEN
663             surf => surf_def_v(l)
664             CALL calc_uvw_abs_v_wgrid
665             CALL calc_us
666             CALL calc_surface_fluxes
667          ENDIF
668       ENDDO 
669!
670!--    Natural-type surfaces
671       DO  l = 0, 3
672          IF ( surf_lsm_v(l)%ns >= 1  )  THEN
673             surf => surf_lsm_v(l)
674             CALL calc_uvw_abs_v_wgrid
675             CALL calc_us
676             CALL calc_surface_fluxes
677          ENDIF
678       ENDDO 
679!
680!--    Urban-type surfaces
681       DO  l = 0, 3
682          IF ( surf_usm_v(l)%ns >= 1  )  THEN
683             surf => surf_usm_v(l)
684             CALL calc_uvw_abs_v_wgrid
685             CALL calc_us
686             CALL calc_surface_fluxes
687          ENDIF
688       ENDDO 
689       mom_w = .FALSE.   
690!
691!--    Calculate momentum fluxes usvs, vsus, wsus and wsvs at vertical
692!--    surfaces for TKE production. Note, here, momentum fluxes are defined
693!--    at grid center and are not staggered as before.
694       mom_tke = .TRUE.
695!
696!--    Default-type surfaces
697       DO  l = 0, 3
698          IF ( surf_def_v(l)%ns >= 1  )  THEN
699             surf => surf_def_v(l)
700             CALL calc_uvw_abs_v_sgrid
701             CALL calc_us
702             CALL calc_surface_fluxes
703          ENDIF
704       ENDDO 
705!
706!--    Natural-type surfaces
707       DO  l = 0, 3
708          IF ( surf_lsm_v(l)%ns >= 1  )  THEN
709             surf => surf_lsm_v(l)
710             CALL calc_uvw_abs_v_sgrid
711             CALL calc_us
712             CALL calc_surface_fluxes
713          ENDIF
714       ENDDO 
715!
716!--    Urban-type surfaces
717       DO  l = 0, 3
718          IF ( surf_usm_v(l)%ns >= 1  )  THEN
719             surf => surf_usm_v(l)
720             CALL calc_uvw_abs_v_sgrid
721             CALL calc_us
722             CALL calc_surface_fluxes
723          ENDIF
724       ENDDO 
725       mom_tke = .FALSE.
726 
727
728    END SUBROUTINE surface_layer_fluxes
729
730
731!------------------------------------------------------------------------------!
732! Description:
733! ------------
734!> Initializing actions for the surface layer routine. Basically, this involves
735!> the preparation of a lookup table for the the bulk Richardson number vs
736!> Obukhov length L when using the lookup table method.
737!------------------------------------------------------------------------------!
738    SUBROUTINE init_surface_layer_fluxes
739
740       IMPLICIT NONE
741
742       INTEGER(iwp) :: li,         & !< Index for loop to create lookup table
743                       num_steps_n   !< Number of non-stretched zeta steps
744
745       LOGICAL :: terminate_run_l = .FALSE.    !< Flag to terminate run (global)
746
747       REAL(wp), PARAMETER ::  zeta_stretch = -10.0_wp !< Start of stretching in the free convection limit
748                               
749       REAL(wp), DIMENSION(:), ALLOCATABLE :: zeta_tmp
750
751
752       REAL(wp) :: zeta_step,            & !< Increment of zeta
753                   regr      = 1.01_wp,  & !< Stretching factor of zeta_step in the free convection limit
754                   regr_old  = 1.0E9_wp, & !< Stretching factor of last iteration step
755                   z0h_min   = 0.0_wp,   & !< Minimum value of z0h to create table
756                   z0_min    = 0.0_wp      !< Minimum value of z0 to create table
757
758
759
760
761!
762!--    In case of runs with neutral statification, set Obukhov length to a
763!--    large value
764       IF ( neutral )  THEN
765          IF ( surf_def_h(0)%ns >= 1 )  surf_def_h(0)%ol = 1.0E10_wp
766          IF ( surf_lsm_h%ns    >= 1 )  surf_lsm_h%ol    = 1.0E10_wp
767          IF ( surf_usm_h%ns    >= 1 )  surf_usm_h%ol    = 1.0E10_wp
768       ENDIF
769
770       IF ( most_method == 'lookup' )  THEN
771
772!
773!--       Check for roughness heterogeneity. In that case terminate run and
774!--       inform user. Check for both, natural and non-natural walls.
775          IF ( surf_def_h(0)%ns >= 1 )  THEN
776             IF ( MINVAL( surf_def_h(0)%z0h ) /= MAXVAL( surf_def_h(0)%z0h )  .OR. &
777                  MINVAL( surf_def_h(0)%z0  ) /= MAXVAL( surf_def_h(0)%z0  ) )  THEN
778                terminate_run_l = .TRUE.
779             ENDIF
780          ENDIF
781          IF ( surf_lsm_h%ns >= 1 )  THEN
782             IF ( MINVAL( surf_lsm_h%z0h ) /= MAXVAL( surf_lsm_h%z0h )  .OR.       &
783                  MINVAL( surf_lsm_h%z0  ) /= MAXVAL( surf_lsm_h%z0  ) )  THEN
784                terminate_run_l = .TRUE.
785             ENDIF
786          ENDIF
787          IF ( surf_usm_h%ns >= 1 )  THEN
788             IF ( MINVAL( surf_usm_h%z0h ) /= MAXVAL( surf_usm_h%z0h )  .OR.       &
789                  MINVAL( surf_usm_h%z0  ) /= MAXVAL( surf_usm_h%z0  ) )  THEN
790                terminate_run_l = .TRUE.
791             ENDIF
792          ENDIF
793!
794!--       Check roughness homogeneity between differt surface types.
795          IF ( surf_lsm_h%ns >= 1  .AND.  surf_def_h(0)%ns >= 1 )  THEN
796             IF ( MINVAL( surf_lsm_h%z0h ) /= MAXVAL( surf_def_h(0)%z0h )  .OR.    &
797                  MINVAL( surf_lsm_h%z0  ) /= MAXVAL( surf_def_h(0)%z0  ) )  THEN
798                terminate_run_l = .TRUE.
799             ENDIF
800          ENDIF
801          IF ( surf_usm_h%ns >= 1  .AND.  surf_def_h(0)%ns >= 1 )  THEN
802             IF ( MINVAL( surf_usm_h%z0h ) /= MAXVAL( surf_def_h(0)%z0h )  .OR.    &
803                  MINVAL( surf_usm_h%z0  ) /= MAXVAL( surf_def_h(0)%z0  ) )  THEN
804                terminate_run_l = .TRUE.
805             ENDIF
806          ENDIF
807          IF ( surf_usm_h%ns >= 1  .AND.  surf_lsm_h%ns >= 1 )  THEN
808             IF ( MINVAL( surf_usm_h%z0h ) /= MAXVAL( surf_lsm_h%z0h )  .OR.       &
809                  MINVAL( surf_usm_h%z0  ) /= MAXVAL( surf_lsm_h%z0  ) )  THEN
810                terminate_run_l = .TRUE.
811             ENDIF
812          ENDIF
813
814
815#if defined( __parallel )
816!
817!--       Make a logical OR for all processes. Force termiation of model if result
818!--       is TRUE
819          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
820          CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL,  &
821                              MPI_LOR, comm2d, ierr )
822#else
823          terminate_run = terminate_run_l
824#endif
825
826          IF ( terminate_run )  THEN
827             message_string = 'most_method = "lookup" cannot be used in ' //   &
828                              'combination with a prescribed roughness '  //   &
829                              'heterogeneity'
830             CALL message( 'surface_layer_fluxes', 'PA0417', 1, 2, 0, 6, 0 )
831          ENDIF
832
833          ALLOCATE(  zeta_tmp(0:num_steps-1) )
834
835!
836!--       Use the lowest possible value for z_mo
837          k    = nzb
838          z_mo = zu(k+1) - zw(k)
839
840!
841!--       Calculate z/L range from zeta_stretch to zeta_max using 90% of the
842!--       available steps (num_steps). The calculation is done with negative
843!--       values of zeta in order to simplify the stretching in the free
844!--       convection limit for the remaining 10% of steps.
845          zeta_tmp(0) = - zeta_max
846          num_steps_n = ( num_steps * 9 / 10 ) - 1
847          zeta_step   = (zeta_max - zeta_stretch) / REAL(num_steps_n)
848
849          DO li = 1, num_steps_n
850             zeta_tmp(li) = zeta_tmp(li-1) + zeta_step
851          ENDDO
852
853!
854!--       Calculate stretching factor for the free convection range
855          DO  WHILE ( ABS( (regr-regr_old) / regr_old ) > 1.0E-10_wp )
856             regr_old = regr
857             regr = ( 1.0_wp - ( -zeta_min / zeta_step ) * ( 1.0_wp - regr )   &
858                    )**( 10.0_wp / REAL(num_steps) )
859          ENDDO
860
861!
862!--       Calculate z/L range from zeta_min to zeta_stretch
863          DO li = num_steps_n+1, num_steps-1
864             zeta_tmp(li) = zeta_tmp(li-1) + zeta_step
865             zeta_step = zeta_step * regr
866          ENDDO
867
868!
869!--       Save roughness lengths to temporary variables
870          IF ( surf_def_h(0)%ns >= 1  )  THEN
871             z0h_min = surf_def_h(0)%z0h(1)
872             z0_min  = surf_def_h(0)%z0(1)
873          ELSEIF ( surf_lsm_h%ns >= 1 )  THEN
874             z0h_min = surf_lsm_h%z0h(1)
875             z0_min  = surf_lsm_h%z0(1)
876          ELSEIF ( surf_usm_h%ns >= 1 )  THEN
877             z0h_min = surf_usm_h%z0h(1)
878             z0_min  = surf_usm_h%z0(1)
879          ENDIF         
880!
881!--       Calculate lookup table for the Richardson number versus Obukhov length
882!--       The Richardson number (rib) is defined depending on the choice of
883!--       boundary conditions for temperature
884          IF ( ibc_pt_b == 1 )  THEN
885             DO li = 0, num_steps-1
886                ol_tab(li)  = - z_mo / zeta_tmp(num_steps-1-li)
887                rib_tab(li) = z_mo / ol_tab(li)  / ( LOG( z_mo / z0_min )       &
888                                                - psi_m( z_mo / ol_tab(li) )    &
889                                                + psi_m( z0_min / ol_tab(li) )  &
890                                                  )**3
891             ENDDO 
892          ELSE
893             DO li = 0, num_steps-1
894                ol_tab(li)  = - z_mo / zeta_tmp(num_steps-1-li)
895                rib_tab(li) = z_mo / ol_tab(li)  * ( LOG( z_mo / z0h_min )     &
896                                              - psi_h( z_mo / ol_tab(li) )     &
897                                              + psi_h( z0h_min / ol_tab(li) )  &
898                                            )                                  &
899                                          / ( LOG( z_mo / z0_min )             &
900                                              - psi_m( z_mo / ol_tab(li) )     &
901                                              + psi_m( z0_min / ol_tab(li) )   &
902                                            )**2
903             ENDDO
904          ENDIF
905
906!
907!--       Determine minimum values of rib in the lookup table. Set upper limit
908!--       to critical Richardson number (0.25)
909          rib_min  = MINVAL(rib_tab)
910          rib_max  = 0.25 !MAXVAL(rib_tab)
911
912          DEALLOCATE( zeta_tmp )
913       ENDIF
914
915    END SUBROUTINE init_surface_layer_fluxes
916
917
918!------------------------------------------------------------------------------!
919! Description:
920! ------------
921!> Compute the absolute value of the horizontal velocity (relative to the
922!> surface) for horizontal surface elements. This is required by all methods.
923!------------------------------------------------------------------------------!
924    SUBROUTINE calc_uvw_abs
925
926       IMPLICIT NONE
927
928       INTEGER(iwp) ::  i             !< running index x direction
929       INTEGER(iwp) ::  ibit          !< flag to mask computation of relative velocity in case of downward-facing surfaces
930       INTEGER(iwp) ::  j             !< running index y direction
931       INTEGER(iwp) ::  k             !< running index z direction
932       INTEGER(iwp) ::  m             !< running index surface elements
933
934!
935!--    ibit is 1 for upward-facing surfaces, zero for downward-facing surfaces.
936       ibit = MERGE( 1, 0, .NOT. downward )
937
938       DO  m = 1, surf%ns
939
940          i   = surf%i(m)           
941          j   = surf%j(m)
942          k   = surf%k(m)
943!
944!--       Compute the absolute value of the horizontal velocity.
945!--       (relative to the surface in case the lower surface is the ocean).
946!--       Please note, in new surface modelling concept the index values changed,
947!--       i.e. the reference grid point is not the surface-grid point itself but
948!--       the first grid point outside of the topography.
949!--       Note, in case of coupled ocean-atmosphere simulations relative velocity
950!--       with respect to the ocean surface is used, hence, (k-1,j,i) values
951!--       are used to calculate the absolute velocity.
952!--       However, this do not apply for downward-facing walls. To mask this,
953!--       use ibit, which checks for upward/downward-facing surfaces.
954          surf%uvw_abs(m) = SQRT(                                              &
955                              ( 0.5_wp * (   u(k,j,i)   + u(k,j,i+1)           &
956                                        -  ( u(k-1,j,i) + u(k-1,j,i+1)         &
957                                           ) * ibit                            &
958                                         )                                     &
959                              )**2 +                                           &
960                              ( 0.5_wp * (   v(k,j,i)   + v(k,j+1,i)           &
961                                        -  ( v(k-1,j,i) + v(k-1,j+1,i)         &
962                                           ) * ibit                            &
963                                         )                                     &
964                              )**2                                             &
965                                )
966
967       ENDDO
968
969    END SUBROUTINE calc_uvw_abs
970
971
972!------------------------------------------------------------------------------!
973! Description:
974! ------------
975!> Compute the absolute value of the horizontal velocity (relative to the
976!> surface) for horizontal surface elements. This is required by all methods.
977!------------------------------------------------------------------------------!
978    SUBROUTINE calc_uvw_abs_v_ugrid
979
980       IMPLICIT NONE
981
982       INTEGER(iwp) ::  i             !< running index x direction
983       INTEGER(iwp) ::  j             !< running index y direction
984       INTEGER(iwp) ::  k             !< running index z direction
985       INTEGER(iwp) ::  m             !< running index surface elements
986
987       REAL(wp)     ::  u_i
988       REAL(wp)     ::  w_i
989
990
991       DO  m = 1, surf%ns
992          i   = surf%i(m)           
993          j   = surf%j(m)
994          k   = surf%k(m)
995!
996!--       Compute the absolute value of the surface parallel velocity on u-grid.
997          u_i  = u(k,j,i)
998          w_i  = 0.25_wp * ( w(k-1,j,i-1) + w(k-1,j,i) +                       &
999                             w(k,j,i-1)   + w(k,j,i) ) 
1000
1001          surf%uvw_abs(m) = SQRT( u_i**2 + w_i**2 ) 
1002
1003       ENDDO
1004
1005    END SUBROUTINE calc_uvw_abs_v_ugrid
1006
1007!------------------------------------------------------------------------------!
1008! Description:
1009! ------------
1010!> Compute the absolute value of the horizontal velocity (relative to the
1011!> surface) for horizontal surface elements. This is required by all methods.
1012!------------------------------------------------------------------------------!
1013    SUBROUTINE calc_uvw_abs_v_vgrid
1014
1015       IMPLICIT NONE
1016
1017       INTEGER(iwp) ::  i             !< running index x direction
1018       INTEGER(iwp) ::  j             !< running index y direction
1019       INTEGER(iwp) ::  k             !< running index z direction
1020       INTEGER(iwp) ::  m             !< running index surface elements
1021
1022       REAL(wp)     ::  v_i
1023       REAL(wp)     ::  w_i
1024
1025
1026       DO  m = 1, surf%ns
1027          i   = surf%i(m)           
1028          j   = surf%j(m)
1029          k   = surf%k(m)
1030
1031          v_i  = u(k,j,i)
1032          w_i  = 0.25_wp * ( w(k-1,j-1,i) + w(k-1,j,i) +                       &
1033                             w(k,j-1,i)   + w(k,j,i) ) 
1034
1035          surf%uvw_abs(m) = SQRT( v_i**2 + w_i**2 ) 
1036
1037       ENDDO
1038
1039    END SUBROUTINE calc_uvw_abs_v_vgrid
1040
1041!------------------------------------------------------------------------------!
1042! Description:
1043! ------------
1044!> Compute the absolute value of the horizontal velocity (relative to the
1045!> surface) for horizontal surface elements. This is required by all methods.
1046!------------------------------------------------------------------------------!
1047    SUBROUTINE calc_uvw_abs_v_wgrid
1048
1049       IMPLICIT NONE
1050
1051       INTEGER(iwp) ::  i             !< running index x direction
1052       INTEGER(iwp) ::  j             !< running index y direction
1053       INTEGER(iwp) ::  k             !< running index z direction
1054       INTEGER(iwp) ::  m             !< running index surface elements
1055
1056       REAL(wp)     ::  u_i
1057       REAL(wp)     ::  v_i
1058       REAL(wp)     ::  w_i
1059!
1060!--    North- (l=0) and south-facing (l=1) surfaces
1061       IF ( l == 0  .OR.  l == 1 )  THEN
1062          DO  m = 1, surf%ns
1063             i   = surf%i(m)           
1064             j   = surf%j(m)
1065             k   = surf%k(m)
1066
1067             u_i  = 0.25_wp * ( u(k+1,j,i+1) + u(k+1,j,i) +                    &
1068                                u(k,j,i+1)   + u(k,j,i) )
1069             v_i  = 0.0_wp
1070             w_i  = w(k,j,i)
1071
1072             surf%uvw_abs(m) = SQRT( u_i**2 + v_i**2 + w_i**2 ) 
1073          ENDDO
1074!
1075!--    East- (l=2) and west-facing (l=3) surfaces
1076       ELSE
1077          DO  m = 1, surf%ns
1078             i   = surf%i(m)           
1079             j   = surf%j(m)
1080             k   = surf%k(m)
1081
1082             u_i  = 0.0_wp
1083             v_i  = 0.25_wp * ( v(k+1,j+1,i) + v(k+1,j,i) +                    &
1084                                v(k,j+1,i)   + v(k,j,i) )
1085             w_i  = w(k,j,i)
1086
1087             surf%uvw_abs(m) = SQRT( u_i**2 + v_i**2 + w_i**2 ) 
1088          ENDDO
1089       ENDIF           
1090
1091    END SUBROUTINE calc_uvw_abs_v_wgrid
1092
1093!------------------------------------------------------------------------------!
1094! Description:
1095! ------------
1096!> Compute the absolute value of the horizontal velocity (relative to the
1097!> surface) for horizontal surface elements. This is required by all methods.
1098!------------------------------------------------------------------------------!
1099    SUBROUTINE calc_uvw_abs_v_sgrid
1100
1101       IMPLICIT NONE
1102
1103       INTEGER(iwp) ::  i             !< running index x direction
1104       INTEGER(iwp) ::  j             !< running index y direction
1105       INTEGER(iwp) ::  k             !< running index z direction
1106       INTEGER(iwp) ::  m             !< running index surface elements
1107
1108       REAL(wp)     ::  u_i
1109       REAL(wp)     ::  v_i
1110       REAL(wp)     ::  w_i
1111
1112!
1113!--    North- (l=0) and south-facing (l=1) walls
1114       IF ( l == 0  .OR.  l == 1 )  THEN
1115          DO  m = 1, surf%ns
1116             i   = surf%i(m)           
1117             j   = surf%j(m)
1118             k   = surf%k(m)
1119
1120             u_i = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
1121             v_i = 0.0_wp
1122             w_i = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
1123
1124             surf%uvw_abs(m) = SQRT( u_i**2 + v_i**2 + w_i**2 ) 
1125          ENDDO
1126!
1127!--    East- (l=2) and west-facing (l=3) walls
1128       ELSE
1129          DO  m = 1, surf%ns
1130             i   = surf%i(m)           
1131             j   = surf%j(m)
1132             k   = surf%k(m)
1133
1134             u_i = 0.0_wp
1135             v_i = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
1136             w_i = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
1137
1138             surf%uvw_abs(m) = SQRT( u_i**2 + v_i**2 + w_i**2 ) 
1139          ENDDO
1140       ENDIF 
1141
1142    END SUBROUTINE calc_uvw_abs_v_sgrid
1143
1144
1145!------------------------------------------------------------------------------!
1146! Description:
1147! ------------
1148!> Calculate the Obukhov length (L) and Richardson flux number (z/L)
1149!------------------------------------------------------------------------------!
1150    SUBROUTINE calc_ol
1151
1152       IMPLICIT NONE
1153
1154       INTEGER(iwp) ::  iter    !< Newton iteration step
1155       INTEGER(iwp) ::  li      !< look index
1156       INTEGER(iwp) ::  m       !< loop variable over all horizontal wall elements
1157
1158       REAL(wp)     :: f,      & !< Function for Newton iteration: f = Ri - [...]/[...]^2 = 0
1159                       f_d_ol, & !< Derivative of f
1160                       ol_l,   & !< Lower bound of L for Newton iteration
1161                       ol_m,   & !< Previous value of L for Newton iteration
1162                       ol_old, & !< Previous time step value of L
1163                       ol_u      !< Upper bound of L for Newton iteration
1164
1165       IF ( TRIM( most_method ) /= 'circular' )  THEN
1166!
1167!--       Evaluate bulk Richardson number (calculation depends on
1168!--       definition based on setting of boundary conditions
1169          IF ( ibc_pt_b /= 1 )  THEN
1170             IF ( humidity )  THEN
1171                !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1172                DO  m = 1, surf%ns
1173
1174                   i   = surf%i(m)           
1175                   j   = surf%j(m)
1176                   k   = surf%k(m)
1177
1178                   z_mo = surf%z_mo(m)
1179
1180                   surf%rib(m) = g * z_mo *                                    &
1181                                         ( vpt(k,j,i) - vpt(k-1,j,i) ) /       &
1182                      ( surf%uvw_abs(m)**2 * vpt(k,j,i) + 1.0E-20_wp )
1183                ENDDO
1184             ELSE
1185                !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1186                DO  m = 1, surf%ns
1187
1188                   i   = surf%i(m)           
1189                   j   = surf%j(m)
1190                   k   = surf%k(m)
1191
1192                   z_mo = surf%z_mo(m)
1193
1194                   surf%rib(m) = g * z_mo *                                    &
1195                                         ( pt(k,j,i) - pt(k-1,j,i)   ) /       &
1196                      ( surf%uvw_abs(m)**2 * pt(k,j,i)  + 1.0E-20_wp )
1197                ENDDO
1198             ENDIF
1199          ELSE
1200             IF ( humidity )  THEN
1201                !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1202                DO  m = 1, surf%ns
1203
1204                   i   = surf%i(m)           
1205                   j   = surf%j(m)
1206                   k   = surf%k(m)
1207
1208                   z_mo = surf%z_mo(m)
1209
1210                   surf%rib(m) = - g * z_mo * ( ( 1.0_wp + 0.61_wp             &
1211                           * q(k,j,i) ) * surf%shf(m) + 0.61_wp                &
1212                           * pt(k,j,i) * surf%qsws(m) ) *                      &
1213                             drho_air_zw(k-1)                /                 &
1214                         ( surf%uvw_abs(m)**3 * vpt(k,j,i) * kappa**2          &
1215                           + 1.0E-20_wp )
1216                ENDDO
1217             ELSE
1218                !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1219                DO  m = 1, surf%ns
1220
1221                   i   = surf%i(m)           
1222                   j   = surf%j(m)
1223                   k   = surf%k(m)
1224
1225                   z_mo = surf%z_mo(m)
1226
1227                   surf%rib(m) = - g * z_mo * surf%shf(m) *                    &
1228                                        drho_air_zw(k-1)            /          &
1229                        ( surf%uvw_abs(m)**3 * pt(k,j,i) * kappa**2            &
1230                           + 1.0E-20_wp )
1231                ENDDO
1232             ENDIF
1233          ENDIF
1234
1235       ENDIF
1236
1237
1238!
1239!--    Calculate the Obukhov length either using a Newton iteration
1240!--    method, via a lookup table, or using the old circular way
1241       IF ( TRIM( most_method ) == 'newton' )  THEN
1242
1243          DO  m = 1, surf%ns
1244
1245             i   = surf%i(m)           
1246             j   = surf%j(m)
1247
1248             z_mo = surf%z_mo(m)
1249
1250!
1251!--          Store current value in case the Newton iteration fails
1252             ol_old = surf%ol(m)
1253
1254!
1255!--          Ensure that the bulk Richardson number and the Obukhov
1256!--          length have the same sign
1257             IF ( surf%rib(m) * surf%ol(m) < 0.0_wp  .OR.                      &
1258                  ABS( surf%ol(m) ) == ol_max )  THEN
1259                IF ( surf%rib(m) > 1.0_wp ) surf%ol(m) =  0.01_wp
1260                IF ( surf%rib(m) < 0.0_wp ) surf%ol(m) = -0.01_wp
1261             ENDIF
1262!
1263!--          Iteration to find Obukhov length
1264             iter = 0
1265             DO
1266                iter = iter + 1
1267!
1268!--             In case of divergence, use the value of the previous time step
1269                IF ( iter > 1000 )  THEN
1270                   surf%ol(m) = ol_old
1271                   EXIT
1272                ENDIF
1273
1274                ol_m = surf%ol(m)
1275                ol_l = ol_m - 0.001_wp * ol_m
1276                ol_u = ol_m + 0.001_wp * ol_m
1277
1278
1279                IF ( ibc_pt_b /= 1 )  THEN
1280!
1281!--                Calculate f = Ri - [...]/[...]^2 = 0
1282                   f = surf%rib(m) - ( z_mo / ol_m ) * (                       &
1283                                                 LOG( z_mo / surf%z0h(m) )     &
1284                                                 - psi_h( z_mo / ol_m )        &
1285                                                 + psi_h( surf%z0h(m) /        &
1286                                                          ol_m )               &
1287                                                               )               &
1288                                              / ( LOG( z_mo / surf%z0(m) )     &
1289                                                 - psi_m( z_mo / ol_m )        &
1290                                                 + psi_m( surf%z0(m) /         &
1291                                                          ol_m )               &
1292                                                 )**2
1293
1294!
1295!--                 Calculate df/dL
1296                    f_d_ol = ( - ( z_mo / ol_u ) * ( LOG( z_mo /               &
1297                                                             surf%z0h(m) )     &
1298                                            - psi_h( z_mo / ol_u )             &
1299                                            + psi_h( surf%z0h(m) / ol_u )      &
1300                                              )                                &
1301                                            / ( LOG( z_mo / surf%z0(m) )       &
1302                                            - psi_m( z_mo / ol_u )             &
1303                                            + psi_m( surf%z0(m) / ol_u )       &
1304                                              )**2                             &
1305                           + ( z_mo / ol_l ) * ( LOG( z_mo / surf%z0h(m) )     &
1306                                            - psi_h( z_mo / ol_l )             &
1307                                            + psi_h( surf%z0h(m) / ol_l )      &
1308                                              )                                &
1309                                            / ( LOG( z_mo / surf%z0(m) )       &
1310                                            - psi_m( z_mo / ol_l )             &
1311                                            + psi_m( surf%z0(m) / ol_l )       &
1312                                              )**2                             &
1313                             ) / ( ol_u - ol_l )
1314                ELSE
1315!
1316!--                Calculate f = Ri - 1 /[...]^3 = 0
1317                   f = surf%rib(m) - ( z_mo / ol_m ) /                         &
1318                                                ( LOG( z_mo / surf%z0(m) )     &
1319                                            - psi_m( z_mo / ol_m )             &
1320                                            + psi_m( surf%z0(m) / ol_m )       &
1321                                                )**3
1322
1323!
1324!--                Calculate df/dL
1325                   f_d_ol = ( - ( z_mo / ol_u ) / ( LOG( z_mo /                &
1326                                                            surf%z0(m) )       &
1327                                            - psi_m( z_mo / ol_u )             &
1328                                            + psi_m( surf%z0(m) / ol_u )       &
1329                                                     )**3                      &
1330                           + ( z_mo / ol_l ) / ( LOG( z_mo / surf%z0(m) )      &
1331                                            - psi_m( z_mo / ol_l )             &
1332                                            + psi_m( surf%z0(m) / ol_l )       &
1333                                               )**3                            &
1334                                  ) / ( ol_u - ol_l )
1335                ENDIF
1336!
1337!--             Calculate new L
1338                surf%ol(m) = ol_m - f / f_d_ol
1339
1340!
1341!--             Ensure that the bulk Richardson number and the Obukhov
1342!--             length have the same sign and ensure convergence.
1343                IF ( surf%ol(m) * ol_m < 0.0_wp )  surf%ol(m) = ol_m * 0.5_wp
1344!
1345!--             If unrealistic value occurs, set L to the maximum
1346!--             value that is allowed
1347                IF ( ABS( surf%ol(m) ) > ol_max )  THEN
1348                   surf%ol(m) = ol_max
1349                   EXIT
1350                ENDIF
1351!
1352!--             Check for convergence
1353                IF ( ABS( ( surf%ol(m) - ol_m ) /                              &
1354                     surf%ol(m) ) < 1.0E-4_wp )  THEN
1355                   EXIT
1356                ELSE
1357                   CYCLE
1358                ENDIF
1359
1360             ENDDO
1361          ENDDO
1362
1363       ELSEIF ( TRIM( most_method ) == 'lookup' )  THEN
1364
1365          !$OMP PARALLEL DO PRIVATE( i, j, z_mo, li ) FIRSTPRIVATE( li_bnd ) LASTPRIVATE( li_bnd )
1366          DO  m = 1, surf%ns
1367
1368             i   = surf%i(m)           
1369             j   = surf%j(m)
1370!
1371!--          If the bulk Richardson number is outside the range of the lookup
1372!--          table, set it to the exceeding threshold value
1373             IF ( surf%rib(m) < rib_min )  surf%rib(m) = rib_min
1374             IF ( surf%rib(m) > rib_max )  surf%rib(m) = rib_max
1375
1376!
1377!--          Find the correct index bounds for linear interpolation. As the
1378!--          Richardson number will not differ very much from time step to
1379!--          time step , use the index from the last step and search in the
1380!--          correct direction
1381             li = li_bnd
1382             IF ( rib_tab(li) - surf%rib(m) > 0.0_wp )  THEN
1383                DO  WHILE ( rib_tab(li-1) - surf%rib(m) > 0.0_wp  .AND.  li > 0 )
1384                   li = li-1
1385                ENDDO
1386             ELSE
1387                DO  WHILE ( rib_tab(li) - surf%rib(m) < 0.0_wp                 &
1388                           .AND.  li < num_steps-1 )
1389                   li = li+1
1390                ENDDO
1391             ENDIF
1392             li_bnd = li
1393
1394!
1395!--          Linear interpolation to find the correct value of z/L
1396             surf%ol(m) = ( ol_tab(li-1) + ( ol_tab(li) - ol_tab(li-1) )       &
1397                         / (  rib_tab(li) - rib_tab(li-1) )                    &
1398                         * ( surf%rib(m) - rib_tab(li-1) ) )
1399
1400          ENDDO
1401
1402       ELSEIF ( TRIM( most_method ) == 'circular' )  THEN
1403
1404          IF ( .NOT. humidity )  THEN
1405             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1406             DO  m = 1, surf%ns
1407
1408                i   = surf%i(m)           
1409                j   = surf%j(m)
1410                k   = surf%k(m)
1411
1412                z_mo = surf%z_mo(m)
1413
1414                surf%ol(m) =  ( pt(k,j,i) *  surf%us(m)**2 ) /                 &
1415                                       ( kappa * g *                           &
1416                                         surf%ts(m) + 1E-30_wp )
1417!
1418!--             Limit the value range of the Obukhov length.
1419!--             This is necessary for very small velocities (u,v --> 1), because
1420!--             the absolute value of ol can then become very small, which in
1421!--             consequence would result in very large shear stresses and very
1422!--             small momentum fluxes (both are generally unrealistic).
1423                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) < zeta_min )         &
1424                   surf%ol(m) = z_mo / zeta_min
1425                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) > zeta_max )         &
1426                   surf%ol(m) = z_mo / zeta_max
1427
1428             ENDDO
1429          ELSEIF ( cloud_physics  .OR.  cloud_droplets )  THEN
1430             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1431             DO  m = 1, surf%ns
1432
1433                i   = surf%i(m)           
1434                j   = surf%j(m)
1435                k   = surf%k(m)
1436
1437                z_mo = surf%z_mo(m)
1438
1439
1440                surf%ol(m) =  ( vpt(k,j,i) * surf%us(m)**2 ) /                 &
1441                    ( kappa * g * ( surf%ts(m) +                               &
1442                         0.61_wp * surf%pt1(m) * surf%us(m)                    &
1443                       + 0.61_wp * surf%qv1(m) * surf%ts(m) -                  &
1444                                   surf%ts(m)  * ql(k,j,i) ) + 1E-30_wp )
1445!
1446!--             Limit the value range of the Obukhov length.
1447!--             This is necessary for very small velocities (u,v --> 1), because
1448!--             the absolute value of ol can then become very small, which in
1449!--             consequence would result in very large shear stresses and very
1450!--             small momentum fluxes (both are generally unrealistic).
1451                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) < zeta_min )         &
1452                   surf%ol(m) = z_mo / zeta_min
1453                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) > zeta_max )         &
1454                   surf%ol(m) = z_mo / zeta_max
1455
1456             ENDDO
1457          ELSE
1458
1459             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1460             DO  m = 1, surf%ns
1461
1462                i   = surf%i(m)           
1463                j   = surf%j(m)
1464                k   = surf%k(m)
1465
1466                z_mo = surf%z_mo(m)
1467
1468                surf%ol(m) =  ( vpt(k,j,i) *  surf%us(m)**2 ) /                &
1469                    ( kappa * g * ( surf%ts(m) + 0.61_wp * pt(k,j,i) *         &
1470                                    surf%qs(m) + 0.61_wp * q(k,j,i)  *         &
1471                                    surf%ts(m) ) + 1E-30_wp )
1472
1473!
1474!--             Limit the value range of the Obukhov length.
1475!--             This is necessary for very small velocities (u,v --> 1), because
1476!--             the absolute value of ol can then become very small, which in
1477!--             consequence would result in very large shear stresses and very
1478!--             small momentum fluxes (both are generally unrealistic).
1479                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) < zeta_min )         &
1480                   surf%ol(m) = z_mo / zeta_min
1481                IF ( ( z_mo / ( surf%ol(m) + 1E-30_wp ) ) > zeta_max )         &
1482                   surf%ol(m) = z_mo / zeta_max
1483
1484             ENDDO
1485
1486          ENDIF
1487
1488       ENDIF
1489
1490    END SUBROUTINE calc_ol
1491
1492!
1493!-- Calculate friction velocity u*
1494    SUBROUTINE calc_us
1495
1496       IMPLICIT NONE
1497
1498       INTEGER(iwp) ::  m       !< loop variable over all horizontal surf elements
1499
1500!
1501!--    Compute u* at horizontal surfaces at the scalars' grid points
1502       IF ( .NOT. surf_vertical )  THEN
1503!
1504!--       Compute u* at upward-facing surfaces
1505          IF ( .NOT. downward )  THEN
1506             !$OMP PARALLEL  DO PRIVATE( z_mo )
1507             DO  m = 1, surf%ns
1508
1509                z_mo = surf%z_mo(m)
1510!
1511!--             Compute u* at the scalars' grid points
1512                surf%us(m) = kappa * surf%uvw_abs(m) /                         &
1513                            ( LOG( z_mo / surf%z0(m) )                         &
1514                           - psi_m( z_mo / surf%ol(m) )                        &
1515                           + psi_m( surf%z0(m) / surf%ol(m) ) )
1516   
1517             ENDDO
1518!
1519!--       Compute u* at downward-facing surfaces. This case, do not consider
1520!--       any stability.
1521          ELSE
1522             !$OMP PARALLEL  DO PRIVATE( z_mo )
1523             DO  m = 1, surf%ns
1524
1525                z_mo = surf%z_mo(m)
1526!
1527!--             Compute u* at the scalars' grid points
1528                surf%us(m) = kappa * surf%uvw_abs(m) / LOG( z_mo / surf%z0(m) )
1529   
1530             ENDDO
1531          ENDIF
1532!
1533!--    Compute u* at vertical surfaces at the u/v/v grid, respectively.
1534!--    No stability is considered in this case.
1535       ELSE
1536          !$OMP PARALLEL DO PRIVATE( z_mo )
1537          DO  m = 1, surf%ns
1538             z_mo = surf%z_mo(m)
1539
1540             surf%us(m) = kappa * surf%uvw_abs(m) / LOG( z_mo / surf%z0(m) )
1541          ENDDO
1542       ENDIF
1543
1544    END SUBROUTINE calc_us
1545
1546!
1547!-- Calculate potential temperature and specific humidity at first grid level
1548!-- ( only for upward-facing surfs )
1549    SUBROUTINE calc_pt_q
1550
1551       IMPLICIT NONE
1552
1553       INTEGER(iwp) ::  m       !< loop variable over all horizontal surf elements
1554
1555       !$OMP PARALLEL DO PRIVATE( i, j, k )
1556       DO  m = 1, surf%ns 
1557
1558          i   = surf%i(m)           
1559          j   = surf%j(m)
1560          k   = surf%k(m)
1561
1562          IF ( cloud_physics ) THEN
1563             surf%pt1(m) = pt(k,j,i) + l_d_cp * pt_d_t(k) * ql(k,j,i)
1564             surf%qv1(m) = q(k,j,i) - ql(k,j,i)
1565          ELSEIF( cloud_droplets ) THEN
1566             surf%pt1(m) = pt(k,j,i) + l_d_cp * pt_d_t(k) * ql(k,j,i)
1567             surf%qv1(m) = q(k,j,i) 
1568          ELSE
1569             surf%pt1(m) = pt(k,j,i)
1570             IF ( humidity )  THEN
1571                surf%qv1(m) = q(k,j,i)
1572             ELSE
1573                surf%qv1(m) = 0.0_wp
1574             ENDIF
1575          ENDIF
1576
1577       ENDDO
1578
1579    END SUBROUTINE calc_pt_q
1580
1581
1582!
1583!-- Calculate potential temperature and specific humidity at first grid level
1584!-- ( only for upward-facing surfs )
1585    SUBROUTINE calc_pt_surface
1586
1587       IMPLICIT NONE
1588
1589       INTEGER(iwp) ::  koff    !< index offset between surface and atmosphere grid point (-1 for upward-, +1 for downward-facing walls)
1590       INTEGER(iwp) ::  m       !< loop variable over all horizontal surf elements
1591       
1592       koff = surf%koff
1593       !$OMP PARALLEL DO PRIVATE( i, j, k )
1594       DO  m = 1, surf%ns 
1595
1596          i   = surf%i(m)           
1597          j   = surf%j(m)
1598          k   = surf%k(m)
1599
1600          surf%pt_surface(m) = pt(k+koff,j,i)
1601
1602       ENDDO
1603
1604    END SUBROUTINE calc_pt_surface
1605
1606!
1607!-- Calculate the other MOST scaling parameters theta*, q*, (qc*, qr*, nc*, nr*)
1608    SUBROUTINE calc_scaling_parameters
1609
1610       IMPLICIT NONE
1611
1612
1613       INTEGER(iwp)  ::  m       !< loop variable over all horizontal surf elements
1614       INTEGER(iwp)  ::  lsp     !< running index for chemical species
1615!
1616!--    Compute theta* at horizontal surfaces
1617       IF ( constant_heatflux  .AND.  .NOT. surf_vertical )  THEN
1618!
1619!--       For a given heat flux in the surface layer:
1620
1621          !$OMP PARALLEL DO PRIVATE( i, j, k )
1622          DO  m = 1, surf%ns 
1623
1624             i   = surf%i(m)           
1625             j   = surf%j(m)
1626             k   = surf%k(m)
1627
1628             surf%ts(m) = -surf%shf(m) * drho_air_zw(k-1) /                    &
1629                                  ( surf%us(m) + 1E-30_wp )
1630
1631!
1632!--          ts must be limited, because otherwise overflow may occur in case
1633!--          of us=0 when computing ol further below
1634             IF ( surf%ts(m) < -1.05E5_wp )  surf%ts(m) = -1.0E5_wp
1635             IF ( surf%ts(m) >  1.0E5_wp  )  surf%ts(m) =  1.0E5_wp
1636
1637          ENDDO
1638
1639       ELSEIF ( .NOT. surf_vertical ) THEN
1640!
1641!--       For a given surface temperature:
1642          IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
1643
1644             !$OMP PARALLEL DO PRIVATE( i, j, k )
1645             DO  m = 1, surf%ns 
1646                i   = surf%i(m)           
1647                j   = surf%j(m)
1648                k   = surf%k(m)
1649
1650                pt(k-1,j,i) = pt_surface
1651             ENDDO
1652          ENDIF
1653
1654          !$OMP PARALLEL DO PRIVATE( z_mo )
1655          DO  m = 1, surf%ns   
1656
1657             z_mo = surf%z_mo(m)
1658
1659             surf%ts(m) = kappa * ( surf%pt1(m) - surf%pt_surface(m) )      &
1660                                  / ( LOG( z_mo / surf%z0h(m) )             &
1661                                      - psi_h( z_mo / surf%ol(m) )          &
1662                                      + psi_h( surf%z0h(m) / surf%ol(m) ) )
1663
1664          ENDDO
1665
1666       ENDIF
1667!
1668!--    Compute theta* at vertical surfaces. This is only required in case of
1669!--    land-surface model, in order to compute aerodynamical resistance.
1670       IF ( surf_vertical )  THEN
1671          !$OMP PARALLEL DO PRIVATE( i, j )
1672          DO  m = 1, surf%ns 
1673
1674             i          =  surf%i(m)           
1675             j          =  surf%j(m)
1676             surf%ts(m) = -surf%shf(m) / ( surf%us(m) + 1E-30_wp )
1677!
1678!--          ts must be limited, because otherwise overflow may occur in case
1679!--          of us=0 when computing ol further below
1680             IF ( surf%ts(m) < -1.05E5_wp )  surf%ts(m) = -1.0E5_wp
1681             IF ( surf%ts(m) >  1.0E5_wp  )  surf%ts(m) =  1.0E5_wp
1682
1683          ENDDO
1684       ENDIF
1685
1686!
1687!--    If required compute q* at horizontal surfaces
1688       IF ( humidity )  THEN
1689          IF ( constant_waterflux  .AND.  .NOT. surf_vertical )  THEN
1690!
1691!--          For a given water flux in the surface layer
1692             !$OMP PARALLEL DO PRIVATE( i, j, k )
1693             DO  m = 1, surf%ns 
1694
1695                i   = surf%i(m)           
1696                j   = surf%j(m)
1697                k   = surf%k(m)
1698                surf%qs(m) = -surf%qsws(m) * drho_air_zw(k-1) /                &
1699                                               ( surf%us(m) + 1E-30_wp )
1700
1701             ENDDO
1702
1703          ELSEIF ( .NOT. surf_vertical )  THEN
1704             coupled_run = ( coupling_mode == 'atmosphere_to_ocean'  .AND.     &
1705                             run_coupled )
1706
1707             IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
1708                !$OMP PARALLEL DO PRIVATE( i, j, k )
1709                DO  m = 1, surf%ns 
1710
1711                   i   = surf%i(m)           
1712                   j   = surf%j(m)
1713                   k   = surf%k(m)
1714                   q(k-1,j,i) = q_surface
1715                   
1716                ENDDO
1717             ENDIF
1718
1719!
1720!--          Assume saturation for atmosphere coupled to ocean (but not
1721!--          in case of precursor runs)
1722             IF ( coupled_run )  THEN
1723                !$OMP PARALLEL DO PRIVATE( i, j, k, e_s )
1724                DO  m = 1, surf%ns   
1725                   i   = surf%i(m)           
1726                   j   = surf%j(m)
1727                   k   = surf%k(m)
1728                   e_s = 6.1_wp * &
1729                              EXP( 0.07_wp * ( MIN(pt(k-1,j,i),pt(k,j,i))      &
1730                                               - 273.15_wp ) )
1731                   q(k-1,j,i) = 0.622_wp * e_s / ( surface_pressure - e_s )
1732                ENDDO
1733             ENDIF
1734
1735             IF ( cloud_physics  .OR.  cloud_droplets )  THEN
1736               !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1737                DO  m = 1, surf%ns   
1738
1739                   i   = surf%i(m)           
1740                   j   = surf%j(m)
1741                   k   = surf%k(m)
1742   
1743                   z_mo = surf%z_mo(m)
1744
1745                   surf%qs(m) = kappa * ( surf%qv1(m) - q(k-1,j,i) )           &
1746                                        / ( LOG( z_mo / surf%z0q(m) )          &
1747                                            - psi_h( z_mo / surf%ol(m) )       &
1748                                            + psi_h( surf%z0q(m) /             &
1749                                                     surf%ol(m) ) )
1750                ENDDO
1751             ELSE
1752                !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1753                DO  m = 1, surf%ns   
1754
1755                   i   = surf%i(m)           
1756                   j   = surf%j(m)
1757                   k   = surf%k(m)
1758   
1759                   z_mo = surf%z_mo(m)
1760
1761                   surf%qs(m) = kappa * ( q(k,j,i) - q(k-1,j,i) )              &
1762                                        / ( LOG( z_mo / surf%z0q(m) )          &
1763                                            - psi_h( z_mo / surf%ol(m) )       &
1764                                            + psi_h( surf%z0q(m) /             &
1765                                                     surf%ol(m) ) )
1766                ENDDO
1767             ENDIF
1768          ENDIF
1769!
1770!--       Compute q* at vertical surfaces
1771          IF ( surf_vertical )  THEN
1772             !$OMP PARALLEL DO PRIVATE( i, j )
1773             DO  m = 1, surf%ns 
1774
1775                i          =  surf%i(m)           
1776                j          =  surf%j(m)
1777                surf%qs(m) = -surf%qsws(m) / ( surf%us(m) + 1E-30_wp )
1778
1779             ENDDO
1780          ENDIF
1781       ENDIF
1782       
1783!
1784!--    If required compute s*
1785       IF ( passive_scalar )  THEN
1786!
1787!--       At horizontal surfaces
1788          IF ( constant_scalarflux  .AND.  .NOT. surf_vertical )  THEN
1789!
1790!--          For a given scalar flux in the surface layer
1791             !$OMP PARALLEL DO PRIVATE( i, j )
1792             DO  m = 1, surf%ns 
1793                i   = surf%i(m)           
1794                j   = surf%j(m)
1795                surf%ss(m) = -surf%ssws(m) / ( surf%us(m) + 1E-30_wp )
1796             ENDDO
1797          ENDIF
1798!
1799!--       At vertical surfaces
1800          IF ( surf_vertical )  THEN
1801             !$OMP PARALLEL DO PRIVATE( i, j )
1802             DO  m = 1, surf%ns 
1803                i          =  surf%i(m)           
1804                j          =  surf%j(m)
1805                surf%ss(m) = -surf%ssws(m) / ( surf%us(m) + 1E-30_wp )
1806             ENDDO
1807          ENDIF
1808       ENDIF
1809
1810!
1811!--    If required compute cs* (chemical species)
1812#if defined( __chem )
1813       IF ( air_chemistry  )  THEN 
1814!
1815!--       At horizontal surfaces                             
1816          DO  lsp = 1, nvar
1817             IF ( constant_csflux(lsp)  .AND.  .NOT.  surf_vertical )  THEN
1818!--             For a given chemical species' flux in the surface layer
1819                !$OMP PARALLEL DO PRIVATE( i, j )
1820                DO  m = 1, surf%ns 
1821                   i   = surf%i(m)           
1822                   j   = surf%j(m)
1823                   surf%css(lsp,m) = -surf%cssws(lsp,m) / ( surf%us(m) + 1E-30_wp )
1824                ENDDO
1825             ENDIF
1826          ENDDO
1827!
1828!--       At vertical surfaces
1829          IF ( surf_vertical )  THEN
1830             DO  lsp = 1, nvar
1831                !$OMP PARALLEL DO PRIVATE( i, j )
1832                DO  m = 1, surf%ns 
1833                   i   = surf%i(m)           
1834                   j   = surf%j(m)
1835                   surf%css(lsp,m) = -surf%cssws(lsp,m) / ( surf%us(m) + 1E-30_wp )
1836                ENDDO
1837             ENDDO
1838          ENDIF
1839       ENDIF
1840#endif
1841
1842!
1843!--    If required compute qc* and nc*
1844       IF ( cloud_physics  .AND.  microphysics_morrison  .AND.                 &
1845            .NOT. surf_vertical )  THEN
1846          !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1847          DO  m = 1, surf%ns   
1848
1849             i    = surf%i(m)           
1850             j    = surf%j(m)
1851             k    = surf%k(m)
1852
1853             z_mo = surf%z_mo(m)
1854
1855             surf%qcs(m) = kappa * ( qc(k,j,i) - qc(k-1,j,i) )                 &
1856                                 / ( LOG( z_mo / surf%z0q(m) )                 &
1857                                 - psi_h( z_mo / surf%ol(m) )                  &
1858                                 + psi_h( surf%z0q(m) / surf%ol(m) ) )
1859
1860             surf%ncs(m) = kappa * ( nc(k,j,i) - nc(k-1,j,i) )                 &
1861                                 / ( LOG( z_mo / surf%z0q(m) )                 &
1862                                 - psi_h( z_mo / surf%ol(m) )                  &
1863                                 + psi_h( surf%z0q(m) / surf%ol(m) ) )
1864          ENDDO
1865
1866       ENDIF
1867
1868!
1869!--    If required compute qr* and nr*
1870       IF ( cloud_physics  .AND.  microphysics_seifert  .AND.                  &
1871            .NOT. surf_vertical )  THEN
1872          !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1873          DO  m = 1, surf%ns   
1874
1875             i    = surf%i(m)           
1876             j    = surf%j(m)
1877             k    = surf%k(m)
1878
1879             z_mo = surf%z_mo(m)
1880
1881             surf%qrs(m) = kappa * ( qr(k,j,i) - qr(k-1,j,i) )                 &
1882                                 / ( LOG( z_mo / surf%z0q(m) )                 &
1883                                 - psi_h( z_mo / surf%ol(m) )                  &
1884                                 + psi_h( surf%z0q(m) / surf%ol(m) ) )
1885
1886             surf%nrs(m) = kappa * ( nr(k,j,i) - nr(k-1,j,i) )                 &
1887                                 / ( LOG( z_mo / surf%z0q(m) )                 &
1888                                 - psi_h( z_mo / surf%ol(m) )                  &
1889                                 + psi_h( surf%z0q(m) / surf%ol(m) ) )
1890          ENDDO
1891
1892       ENDIF
1893
1894    END SUBROUTINE calc_scaling_parameters
1895
1896
1897
1898!
1899!-- Calculate surface fluxes usws, vsws, shf, qsws, (qcsws, qrsws, ncsws, nrsws)
1900    SUBROUTINE calc_surface_fluxes
1901
1902       IMPLICIT NONE
1903
1904       INTEGER(iwp)  ::  m       !< loop variable over all horizontal surf elements
1905       INTEGER(iwp)  ::  lsp     !< running index for chemical species
1906
1907       REAL(wp)                            ::  dum     !< dummy to precalculate logarithm
1908       REAL(wp)                            ::  flag_u  !< flag indicating u-grid, used for calculation of horizontal momentum fluxes at vertical surfaces
1909       REAL(wp)                            ::  flag_v  !< flag indicating v-grid, used for calculation of horizontal momentum fluxes at vertical surfaces
1910       REAL(wp), DIMENSION(:), ALLOCATABLE ::  u_i     !< u-component interpolated onto scalar grid point, required for momentum fluxes at vertical surfaces
1911       REAL(wp), DIMENSION(:), ALLOCATABLE ::  v_i     !< v-component interpolated onto scalar grid point, required for momentum fluxes at vertical surfaces
1912       REAL(wp), DIMENSION(:), ALLOCATABLE ::  w_i     !< w-component interpolated onto scalar grid point, required for momentum fluxes at vertical surfaces
1913
1914!
1915!--    Calcuate surface fluxes at horizontal walls
1916       IF ( .NOT. surf_vertical )  THEN
1917!
1918!--       Compute u'w' for the total model domain at upward-facing surfaces.
1919!--       First compute the corresponding component of u* and square it.
1920          IF ( .NOT. downward )  THEN
1921             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1922             DO  m = 1, surf%ns 
1923   
1924                i = surf%i(m)           
1925                j = surf%j(m)
1926                k = surf%k(m)
1927
1928                z_mo = surf%z_mo(m)
1929
1930                surf%usws(m) = kappa * ( u(k,j,i) - u(k-1,j,i) )               &
1931                              / ( LOG( z_mo / surf%z0(m) )                     &
1932                                  - psi_m( z_mo / surf%ol(m) )                 &
1933                                  + psi_m( surf%z0(m) / surf%ol(m) ) )
1934!
1935!--             Please note, the computation of usws is not fully accurate. Actually
1936!--             a further interpolation of us onto the u-grid, where usws is defined,
1937!--             is required. However, this is not done as this would require several
1938!--             data transfers between 2D-grid and the surf-type.
1939!--             The impact of the missing interpolation is negligible as several
1940!--             tests had shown.
1941!--             Same also for ol. 
1942                surf%usws(m) = -surf%usws(m) * surf%us(m) * rho_air_zw(k-1)
1943
1944             ENDDO
1945!
1946!--       At downward-facing surfaces
1947          ELSE
1948             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1949             DO  m = 1, surf%ns 
1950   
1951                i = surf%i(m)           
1952                j = surf%j(m)
1953                k = surf%k(m)
1954
1955                z_mo = surf%z_mo(m)
1956
1957                surf%usws(m) = kappa * u(k,j,i) / LOG( z_mo / surf%z0(m) )
1958                surf%usws(m) = surf%usws(m) * surf%us(m) * rho_air_zw(k)
1959
1960             ENDDO     
1961          ENDIF
1962
1963!
1964!--       Compute v'w' for the total model domain.
1965!--       First compute the corresponding component of u* and square it.
1966!--       Upward-facing surfaces
1967          IF ( .NOT. downward )  THEN
1968             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1969             DO  m = 1, surf%ns 
1970                i = surf%i(m)           
1971                j = surf%j(m)
1972                k = surf%k(m)
1973
1974                z_mo = surf%z_mo(m)
1975
1976                surf%vsws(m) = kappa * ( v(k,j,i) - v(k-1,j,i) )               &
1977                           / ( LOG( z_mo / surf%z0(m) )                        &
1978                               - psi_m( z_mo / surf%ol(m) )                    &
1979                               + psi_m( surf%z0(m) / surf%ol(m) ) )
1980!
1981!--             Please note, the computation of vsws is not fully accurate. Actually
1982!--             a further interpolation of us onto the v-grid, where vsws is defined,
1983!--             is required. However, this is not done as this would require several
1984!--             data transfers between 2D-grid and the surf-type.
1985!--             The impact of the missing interpolation is negligible as several
1986!--             tests had shown.
1987!--             Same also for ol. 
1988                surf%vsws(m) = -surf%vsws(m) * surf%us(m) * rho_air_zw(k-1)
1989             ENDDO
1990!
1991!--       Downward-facing surfaces
1992          ELSE
1993             !$OMP PARALLEL DO PRIVATE( i, j, k, z_mo )
1994             DO  m = 1, surf%ns 
1995                i = surf%i(m)           
1996                j = surf%j(m)
1997                k = surf%k(m)
1998
1999                z_mo = surf%z_mo(m)
2000
2001                surf%vsws(m) = kappa * v(k,j,i) / LOG( z_mo / surf%z0(m) )
2002                surf%vsws(m) = surf%vsws(m) * surf%us(m) * rho_air_zw(k)
2003             ENDDO
2004          ENDIF
2005!
2006!--       Compute the vertical kinematic heat flux
2007          IF (  .NOT.  constant_heatflux  .AND.  ( ( time_since_reference_point&
2008               <=  skip_time_do_lsm  .AND. simulated_time > 0.0_wp ) .OR.      &
2009               .NOT.  land_surface )  .AND.  .NOT. urban_surface  .AND.        &
2010               .NOT. downward )  THEN
2011             !$OMP PARALLEL DO PRIVATE( i, j, k )
2012             DO  m = 1, surf%ns 
2013                i    = surf%i(m)           
2014                j    = surf%j(m)
2015                k    = surf%k(m)
2016                surf%shf(m) = -surf%ts(m) * surf%us(m) * rho_air_zw(k-1)
2017             ENDDO
2018          ENDIF
2019!
2020!--       Compute the vertical water flux
2021          IF (  .NOT.  constant_waterflux  .AND.  humidity  .AND.              &
2022               ( ( time_since_reference_point <= skip_time_do_lsm  .AND.       &
2023               simulated_time > 0.0_wp ) .OR.  .NOT.  land_surface  )  .AND.   &
2024               .NOT.  urban_surface  .AND.  .NOT. downward )  THEN
2025             !$OMP PARALLEL DO PRIVATE( i, j, k )
2026             DO  m = 1, surf%ns 
2027                i    = surf%i(m)           
2028                j    = surf%j(m)
2029                k    = surf%k(m)
2030                surf%qsws(m) = -surf%qs(m) * surf%us(m) * rho_air_zw(k-1)
2031             ENDDO
2032          ENDIF
2033!
2034!--       Compute the vertical scalar flux
2035          IF (  .NOT.  constant_scalarflux  .AND.  passive_scalar  .AND.       &
2036                .NOT.  downward )  THEN
2037             !$OMP PARALLEL DO PRIVATE( i, j )
2038             DO  m = 1, surf%ns   
2039
2040                i    = surf%i(m)           
2041                j    = surf%j(m)
2042                surf%ssws(m) = -surf%ss(m) * surf%us(m)
2043
2044             ENDDO
2045          ENDIF   
2046!
2047!--       Compute the vertical chemical species' flux
2048#if defined( __chem )
2049          DO  lsp = 1, nvar
2050             IF (  .NOT.  constant_csflux(lsp)  .AND.  air_chemistry  .AND.    &
2051                   .NOT.  downward )  THEN
2052                !$OMP PARALLEL DO PRIVATE( i, j )
2053                DO  m = 1, surf%ns   
2054                   i     = surf%i(m)           
2055                   j     = surf%j(m)
2056                   surf%cssws(lsp,m) = -surf%css(lsp,m) * surf%us(m)
2057                ENDDO
2058             ENDIF   
2059          ENDDO
2060#endif
2061
2062!
2063!--       Compute (turbulent) fluxes of cloud water content and cloud drop conc.
2064          IF ( cloud_physics  .AND.  microphysics_morrison  .AND.              &
2065               .NOT. downward)  THEN
2066             !$OMP PARALLEL DO PRIVATE( i, j )
2067             DO  m = 1, surf%ns   
2068
2069                i    = surf%i(m)           
2070                j    = surf%j(m)
2071
2072                surf%qcsws(m) = -surf%qcs(m) * surf%us(m)
2073                surf%ncsws(m) = -surf%ncs(m) * surf%us(m)
2074             ENDDO
2075          ENDIF   
2076!
2077!--       Compute (turbulent) fluxes of rain water content and rain drop conc.
2078          IF ( cloud_physics  .AND.  microphysics_seifert  .AND.               &
2079               .NOT. downward)  THEN
2080             !$OMP PARALLEL DO PRIVATE( i, j )
2081             DO  m = 1, surf%ns   
2082
2083                i    = surf%i(m)           
2084                j    = surf%j(m)
2085
2086                surf%qrsws(m) = -surf%qrs(m) * surf%us(m)
2087                surf%nrsws(m) = -surf%nrs(m) * surf%us(m)
2088             ENDDO
2089          ENDIF
2090
2091!
2092!--       Bottom boundary condition for the TKE.
2093          IF ( ibc_e_b == 2 )  THEN
2094             !$OMP PARALLEL DO PRIVATE( i, j, k )
2095             DO  m = 1, surf%ns   
2096
2097                i    = surf%i(m)           
2098                j    = surf%j(m)
2099                k    = surf%k(m)
2100
2101                e(k,j,i) = ( surf%us(m) / 0.1_wp )**2
2102!
2103!--             As a test: cm = 0.4
2104!               e(k,j,i) = ( us(j,i) / 0.4_wp )**2
2105                e(k-1,j,i)   = e(k,j,i)
2106
2107             ENDDO
2108          ENDIF
2109!
2110!--    Calcuate surface fluxes at vertical surfaces. No stability is considered.
2111       ELSE
2112!
2113!--       Compute usvs l={0,1} and vsus l={2,3}
2114          IF ( mom_uv )  THEN
2115!
2116!--          Generalize computation by introducing flags. At north- and south-
2117!--          facing surfaces u-component is used, at east- and west-facing
2118!--          surfaces v-component is used.
2119             flag_u = MERGE( 1.0_wp, 0.0_wp, l == 0  .OR.  l == 1 )   
2120             flag_v = MERGE( 1.0_wp, 0.0_wp, l == 2  .OR.  l == 3 )   
2121             !$OMP PARALLEL  DO PRIVATE( i, j, k, z_mo )
2122             DO  m = 1, surf%ns 
2123                i = surf%i(m)           
2124                j = surf%j(m)
2125                k = surf%k(m)
2126
2127                z_mo = surf%z_mo(m)
2128
2129                surf%mom_flux_uv(m) = kappa *                                  &
2130                                ( flag_u * u(k,j,i) + flag_v * v(k,j,i) )  /   &
2131                                                        LOG( z_mo / surf%z0(m) )
2132
2133               surf%mom_flux_uv(m) =                                           &
2134                                    - surf%mom_flux_uv(m) * surf%us(m)
2135             ENDDO
2136          ENDIF
2137!
2138!--       Compute wsus l={0,1} and wsvs l={2,3}
2139          IF ( mom_w )  THEN
2140             !$OMP PARALLEL  DO PRIVATE( i, j, k, z_mo )
2141             DO  m = 1, surf%ns 
2142                i = surf%i(m)           
2143                j = surf%j(m)
2144                k = surf%k(m)
2145
2146                z_mo = surf%z_mo(m)
2147
2148                surf%mom_flux_w(m) = kappa * w(k,j,i) / LOG( z_mo / surf%z0(m) )
2149
2150                surf%mom_flux_w(m) =                                           &
2151                                     - surf%mom_flux_w(m) * surf%us(m)
2152             ENDDO
2153          ENDIF
2154!
2155!--       Compute momentum fluxes used for subgrid-scale TKE production at
2156!--       vertical surfaces. In constrast to the calculated momentum fluxes at
2157!--       vertical surfaces before, which are defined on the u/v/w-grid,
2158!--       respectively), the TKE fluxes are defined at the scalar grid.
2159!--       
2160          IF ( mom_tke )  THEN
2161!
2162!--          Precalculate velocity components at scalar grid point.
2163             ALLOCATE( u_i(1:surf%ns) )
2164             ALLOCATE( v_i(1:surf%ns) )
2165             ALLOCATE( w_i(1:surf%ns) )
2166
2167             IF ( l == 0  .OR.  l == 1 )  THEN
2168                !$OMP PARALLEL DO PRIVATE( i, j, k )
2169                DO  m = 1, surf%ns 
2170                   i = surf%i(m)           
2171                   j = surf%j(m)
2172                   k = surf%k(m)
2173
2174                   u_i(m) = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
2175                   v_i(m) = 0.0_wp
2176                   w_i(m) = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
2177                ENDDO
2178             ELSE
2179                !$OMP PARALLEL DO PRIVATE( i, j, k )
2180                DO  m = 1, surf%ns 
2181                   i = surf%i(m)           
2182                   j = surf%j(m)
2183                   k = surf%k(m)
2184
2185                   u_i(m) = 0.0_wp
2186                   v_i(m) = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
2187                   w_i(m) = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
2188                ENDDO
2189             ENDIF
2190
2191             !$OMP PARALLEL DO PRIVATE( i, j, dum, z_mo )
2192             DO  m = 1, surf%ns 
2193                i = surf%i(m)           
2194                j = surf%j(m)
2195
2196                z_mo = surf%z_mo(m)
2197
2198                dum = kappa / LOG( z_mo / surf%z0(m) )
2199!
2200!--             usvs (l=0,1) and vsus (l=2,3)
2201                surf%mom_flux_tke(0,m) = dum * ( u_i(m) + v_i(m) )
2202!
2203!--             wsvs (l=0,1) and wsus (l=2,3)
2204                surf%mom_flux_tke(1,m) = dum * w_i(m)
2205
2206                surf%mom_flux_tke(0:1,m) =                                     &
2207                               - surf%mom_flux_tke(0:1,m) * surf%us(m)
2208             ENDDO
2209!
2210!--          Deallocate temporary arrays
2211             DEALLOCATE( u_i )             
2212             DEALLOCATE( v_i ) 
2213             DEALLOCATE( w_i ) 
2214          ENDIF
2215       ENDIF
2216
2217    END SUBROUTINE calc_surface_fluxes
2218
2219
2220!
2221!-- Integrated stability function for momentum
2222    FUNCTION psi_m( zeta ) 
2223       
2224       USE kinds
2225
2226       IMPLICIT NONE
2227
2228       REAL(wp)            :: psi_m !< Integrated similarity function result
2229       REAL(wp)            :: zeta  !< Stability parameter z/L
2230       REAL(wp)            :: x     !< dummy variable
2231
2232       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
2233       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
2234       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
2235       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
2236       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
2237       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
2238
2239
2240       IF ( zeta < 0.0_wp )  THEN
2241          x = SQRT( SQRT( 1.0_wp  - 16.0_wp * zeta ) )
2242          psi_m = pi * 0.5_wp - 2.0_wp * ATAN( x ) + LOG( ( 1.0_wp + x )**2    &
2243                  * ( 1.0_wp + x**2 ) * 0.125_wp )
2244       ELSE
2245
2246          psi_m = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - a * zeta         &
2247                   - bc_d_d
2248!
2249!--       Old version for stable conditions (only valid for z/L < 0.5)
2250!--       psi_m = - 5.0_wp * zeta
2251
2252       ENDIF
2253
2254    END FUNCTION psi_m
2255
2256
2257!
2258!-- Integrated stability function for heat and moisture
2259    FUNCTION psi_h( zeta ) 
2260       
2261       USE kinds
2262
2263       IMPLICIT NONE
2264
2265       REAL(wp)            :: psi_h !< Integrated similarity function result
2266       REAL(wp)            :: zeta  !< Stability parameter z/L
2267       REAL(wp)            :: x     !< dummy variable
2268
2269       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
2270       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
2271       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
2272       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
2273       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
2274       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
2275
2276
2277       IF ( zeta < 0.0_wp )  THEN
2278          x = SQRT( 1.0_wp  - 16.0_wp * zeta )
2279          psi_h = 2.0_wp * LOG( (1.0_wp + x ) / 2.0_wp )
2280       ELSE
2281          psi_h = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - (1.0_wp          &
2282                  + 0.66666666666_wp * a * zeta )**1.5_wp - bc_d_d             &
2283                  + 1.0_wp
2284!
2285!--       Old version for stable conditions (only valid for z/L < 0.5)
2286!--       psi_h = - 5.0_wp * zeta
2287       ENDIF
2288
2289    END FUNCTION psi_h
2290
2291 END MODULE surface_layer_fluxes_mod
Note: See TracBrowser for help on using the repository browser.