source: palm/trunk/SOURCE/init_1d_model.f90 @ 1985

Last change on this file since 1985 was 1961, checked in by suehring, 8 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 36.4 KB
Line 
1!> @file init_1d_model.f90
2!--------------------------------------------------------------------------------!
3! This file is part of PALM.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms
6! of the GNU General Public License as published by the Free Software Foundation,
7! either version 3 of the License, or (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
10! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with
14! PALM. If not, see <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2016 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------!
18!
19! Current revisions:
20! -----------------
21!
22!
23! Former revisions:
24! -----------------
25! $Id: init_1d_model.f90 1961 2016-07-12 16:37:58Z suehring $
26!
27! 1960 2016-07-12 16:34:24Z suehring
28! Remove passive_scalar from IF-statements, as 1D-scalar profile is effectively
29! not used.
30! Formatting adjustment
31!
32! 1808 2016-04-05 19:44:00Z raasch
33! routine local_flush replaced by FORTRAN statement
34!
35! 1709 2015-11-04 14:47:01Z maronga
36! Set initial time step to 10 s to avoid instability of the 1d model for small
37! grid spacings
38!
39! 1697 2015-10-28 17:14:10Z raasch
40! small E- and F-FORMAT changes to avoid informative compiler messages about
41! insufficient field width
42!
43! 1691 2015-10-26 16:17:44Z maronga
44! Renamed prandtl_layer to constant_flux_layer. rif is replaced by ol and zeta.
45!
46! 1682 2015-10-07 23:56:08Z knoop
47! Code annotations made doxygen readable
48!
49! 1353 2014-04-08 15:21:23Z heinze
50! REAL constants provided with KIND-attribute
51!
52! 1346 2014-03-27 13:18:20Z heinze
53! Bugfix: REAL constants provided with KIND-attribute especially in call of
54! intrinsic function like MAX, MIN, SIGN
55!
56! 1322 2014-03-20 16:38:49Z raasch
57! REAL functions provided with KIND-attribute
58!
59! 1320 2014-03-20 08:40:49Z raasch
60! ONLY-attribute added to USE-statements,
61! kind-parameters added to all INTEGER and REAL declaration statements,
62! kinds are defined in new module kinds,
63! revision history before 2012 removed,
64! comment fields (!:) to be used for variable explanations added to
65! all variable declaration statements
66!
67! 1036 2012-10-22 13:43:42Z raasch
68! code put under GPL (PALM 3.9)
69!
70! 1015 2012-09-27 09:23:24Z raasch
71! adjustment of mixing length to the Prandtl mixing length at first grid point
72! above ground removed
73!
74! 1001 2012-09-13 14:08:46Z raasch
75! all actions concerning leapfrog scheme removed
76!
77! 996 2012-09-07 10:41:47Z raasch
78! little reformatting
79!
80! 978 2012-08-09 08:28:32Z fricke
81! roughness length for scalar quantities z0h1d added
82!
83! Revision 1.1  1998/03/09 16:22:10  raasch
84! Initial revision
85!
86!
87! Description:
88! ------------
89!> 1D-model to initialize the 3D-arrays.
90!> The temperature profile is set as steady and a corresponding steady solution
91!> of the wind profile is being computed.
92!> All subroutines required can be found within this file.
93!>
94!> @todo harmonize code with new surface_layer_fluxes module
95!> @bug 1D model crashes when using small grid spacings in the order of 1 m
96!------------------------------------------------------------------------------!
97 SUBROUTINE init_1d_model
98 
99
100    USE arrays_3d,                                                             &
101        ONLY:  l_grid, ug, u_init, vg, v_init, zu
102   
103    USE indices,                                                               &
104        ONLY:  nzb, nzt
105   
106    USE kinds
107   
108    USE model_1d,                                                              &
109        ONLY:  e1d, e1d_p, kh1d, km1d, l1d, l_black, qs1d, rif1d,              &
110               simulated_time_1d, te_e, te_em, te_u, te_um, te_v, te_vm, ts1d, &
111               u1d, u1d_p, us1d, usws1d, v1d, v1d_p, vsws1d, z01d, z0h1d
112   
113    USE control_parameters,                                                    &
114        ONLY:  constant_diffusion, constant_flux_layer, f, humidity, kappa,    &
115               km_constant, mixing_length_1d, prandtl_number,                  &
116               roughness_length, simulated_time_chr, z0h_factor
117
118    IMPLICIT NONE
119
120    CHARACTER (LEN=9) ::  time_to_string  !<
121   
122    INTEGER(iwp) ::  k  !<
123   
124    REAL(wp) ::  lambda !<
125
126!
127!-- Allocate required 1D-arrays
128    ALLOCATE( e1d(nzb:nzt+1),    e1d_p(nzb:nzt+1),                             &
129              kh1d(nzb:nzt+1),   km1d(nzb:nzt+1),                              &
130              l_black(nzb:nzt+1), l1d(nzb:nzt+1),                              &
131              rif1d(nzb:nzt+1),   te_e(nzb:nzt+1),                             &
132              te_em(nzb:nzt+1),  te_u(nzb:nzt+1),    te_um(nzb:nzt+1),         &
133              te_v(nzb:nzt+1),   te_vm(nzb:nzt+1),    u1d(nzb:nzt+1),          &
134              u1d_p(nzb:nzt+1),  v1d(nzb:nzt+1),                               &
135              v1d_p(nzb:nzt+1) )
136
137!
138!-- Initialize arrays
139    IF ( constant_diffusion )  THEN
140       km1d = km_constant
141       kh1d = km_constant / prandtl_number
142    ELSE
143       e1d = 0.0_wp; e1d_p = 0.0_wp
144       kh1d = 0.0_wp; km1d = 0.0_wp
145       rif1d = 0.0_wp
146!
147!--    Compute the mixing length
148       l_black(nzb) = 0.0_wp
149
150       IF ( TRIM( mixing_length_1d ) == 'blackadar' )  THEN
151!
152!--       Blackadar mixing length
153          IF ( f /= 0.0_wp )  THEN
154             lambda = 2.7E-4_wp * SQRT( ug(nzt+1)**2 + vg(nzt+1)**2 ) /        &
155                               ABS( f ) + 1E-10_wp
156          ELSE
157             lambda = 30.0_wp
158          ENDIF
159
160          DO  k = nzb+1, nzt+1
161             l_black(k) = kappa * zu(k) / ( 1.0_wp + kappa * zu(k) / lambda )
162          ENDDO
163
164       ELSEIF ( TRIM( mixing_length_1d ) == 'as_in_3d_model' )  THEN
165!
166!--       Use the same mixing length as in 3D model
167          l_black(1:nzt) = l_grid
168          l_black(nzt+1) = l_black(nzt)
169
170       ENDIF
171    ENDIF
172    l1d   = l_black
173    u1d   = u_init
174    u1d_p = u_init
175    v1d   = v_init
176    v1d_p = v_init
177
178!
179!-- Set initial horizontal velocities at the lowest grid levels to a very small
180!-- value in order to avoid too small time steps caused by the diffusion limit
181!-- in the initial phase of a run (at k=1, dz/2 occurs in the limiting formula!)
182    u1d(0:1)   = 0.1_wp
183    u1d_p(0:1) = 0.1_wp
184    v1d(0:1)   = 0.1_wp
185    v1d_p(0:1) = 0.1_wp
186
187!
188!-- For u*, theta* and the momentum fluxes plausible values are set
189    IF ( constant_flux_layer )  THEN
190       us1d = 0.1_wp   ! without initial friction the flow would not change
191    ELSE
192       e1d(nzb+1)  = 1.0_wp
193       km1d(nzb+1) = 1.0_wp
194       us1d = 0.0_wp
195    ENDIF
196    ts1d = 0.0_wp
197    usws1d = 0.0_wp
198    vsws1d = 0.0_wp
199    z01d  = roughness_length
200    z0h1d = z0h_factor * z01d 
201    IF ( humidity )  qs1d = 0.0_wp
202
203!
204!-- Tendencies must be preset in order to avoid runtime errors within the
205!-- first Runge-Kutta step
206    te_em = 0.0_wp
207    te_um = 0.0_wp
208    te_vm = 0.0_wp
209
210!
211!-- Set start time in hh:mm:ss - format
212    simulated_time_chr = time_to_string( simulated_time_1d )
213
214!
215!-- Integrate the 1D-model equations using the leap-frog scheme
216    CALL time_integration_1d
217
218
219 END SUBROUTINE init_1d_model
220
221
222
223!------------------------------------------------------------------------------!
224! Description:
225! ------------
226!> Leap-frog time differencing scheme for the 1D-model.
227!------------------------------------------------------------------------------!
228 
229 SUBROUTINE time_integration_1d
230
231
232    USE arrays_3d,                                                             &
233        ONLY:  dd2zu, ddzu, ddzw, l_grid, pt_init, q_init, ug, vg, zu
234       
235    USE control_parameters,                                                    &
236        ONLY:  constant_diffusion, constant_flux_layer, dissipation_1d,        &
237               humidity, intermediate_timestep_count,                          &
238               intermediate_timestep_count_max, f, g, ibc_e_b, kappa,          & 
239               mixing_length_1d,                                               &
240               simulated_time_chr, timestep_scheme, tsc, zeta_max, zeta_min
241               
242    USE indices,                                                               &
243        ONLY:  nzb, nzb_diff, nzt
244       
245    USE kinds
246   
247    USE model_1d,                                                              &
248        ONLY:  current_timestep_number_1d, damp_level_ind_1d, dt_1d,           &
249               dt_pr_1d, dt_run_control_1d, e1d, e1d_p, end_time_1d,           &
250               kh1d, km1d, l1d, l_black, qs1d, rif1d, simulated_time_1d,       &
251               stop_dt_1d, te_e, te_em, te_u, te_um, te_v, te_vm, time_pr_1d,  &
252               ts1d, time_run_control_1d, u1d, u1d_p, us1d, usws1d, v1d,       &
253               v1d_p, vsws1d, z01d, z0h1d
254       
255    USE pegrid
256
257    IMPLICIT NONE
258
259    CHARACTER (LEN=9) ::  time_to_string  !<
260   
261    INTEGER(iwp) ::  k  !<
262   
263    REAL(wp) ::  a            !<
264    REAL(wp) ::  b            !<
265    REAL(wp) ::  dissipation  !<
266    REAL(wp) ::  dpt_dz       !<
267    REAL(wp) ::  flux         !<
268    REAL(wp) ::  kmzm         !<
269    REAL(wp) ::  kmzp         !<
270    REAL(wp) ::  l_stable     !<
271    REAL(wp) ::  pt_0         !<
272    REAL(wp) ::  uv_total     !<
273
274!
275!-- Determine the time step at the start of a 1D-simulation and
276!-- determine and printout quantities used for run control
277    dt_1d = 10.0_wp
278    CALL run_control_1d
279
280!
281!-- Start of time loop
282    DO  WHILE ( simulated_time_1d < end_time_1d  .AND.  .NOT. stop_dt_1d )
283
284!
285!--    Depending on the timestep scheme, carry out one or more intermediate
286!--    timesteps
287
288       intermediate_timestep_count = 0
289       DO  WHILE ( intermediate_timestep_count < &
290                   intermediate_timestep_count_max )
291
292          intermediate_timestep_count = intermediate_timestep_count + 1
293
294          CALL timestep_scheme_steering
295
296!
297!--       Compute all tendency terms. If a Prandtl-layer is simulated, k starts
298!--       at nzb+2.
299          DO  k = nzb_diff, nzt
300
301             kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
302             kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
303!
304!--          u-component
305             te_u(k) =  f * ( v1d(k) - vg(k) ) + ( &
306                              kmzp * ( u1d(k+1) - u1d(k) ) * ddzu(k+1) &
307                            - kmzm * ( u1d(k) - u1d(k-1) ) * ddzu(k)   &
308                                                 ) * ddzw(k)
309!
310!--          v-component
311             te_v(k) = -f * ( u1d(k) - ug(k) ) + (                     &
312                              kmzp * ( v1d(k+1) - v1d(k) ) * ddzu(k+1) &
313                            - kmzm * ( v1d(k) - v1d(k-1) ) * ddzu(k)   &
314                                                 ) * ddzw(k)
315          ENDDO
316          IF ( .NOT. constant_diffusion )  THEN
317             DO  k = nzb_diff, nzt
318!
319!--             TKE
320                kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
321                kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
322                IF ( .NOT. humidity )  THEN
323                   pt_0 = pt_init(k)
324                   flux =  ( pt_init(k+1)-pt_init(k-1) ) * dd2zu(k)
325                ELSE
326                   pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
327                   flux = ( ( pt_init(k+1) - pt_init(k-1) ) +                  &
328                            0.61_wp * pt_init(k) *                             &
329                            ( q_init(k+1) - q_init(k-1) ) ) * dd2zu(k)
330                ENDIF
331
332                IF ( dissipation_1d == 'detering' )  THEN
333!
334!--                According to Detering, c_e=0.064
335                   dissipation = 0.064_wp * e1d(k) * SQRT( e1d(k) ) / l1d(k)
336                ELSEIF ( dissipation_1d == 'as_in_3d_model' )  THEN
337                   dissipation = ( 0.19_wp + 0.74_wp * l1d(k) / l_grid(k) )    &
338                                 * e1d(k) * SQRT( e1d(k) ) / l1d(k)
339                ENDIF
340
341                te_e(k) = km1d(k) * ( ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2&
342                                    + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2&
343                                    )                                          &
344                                    - g / pt_0 * kh1d(k) * flux                &
345                                    +            (                             &
346                                     kmzp * ( e1d(k+1) - e1d(k) ) * ddzu(k+1)  &
347                                   - kmzm * ( e1d(k) - e1d(k-1) ) * ddzu(k)    &
348                                                 ) * ddzw(k)                   &
349                                   - dissipation
350             ENDDO
351          ENDIF
352
353!
354!--       Tendency terms at the top of the Prandtl-layer.
355!--       Finite differences of the momentum fluxes are computed using half the
356!--       normal grid length (2.0*ddzw(k)) for the sake of enhanced accuracy
357          IF ( constant_flux_layer )  THEN
358
359             k = nzb+1
360             kmzm = 0.5_wp * ( km1d(k-1) + km1d(k) )
361             kmzp = 0.5_wp * ( km1d(k) + km1d(k+1) )
362             IF ( .NOT. humidity )  THEN
363                pt_0 = pt_init(k)
364                flux =  ( pt_init(k+1)-pt_init(k-1) ) * dd2zu(k)
365             ELSE
366                pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
367                flux = ( ( pt_init(k+1) - pt_init(k-1) ) +                     &
368                         0.61_wp * pt_init(k) * ( q_init(k+1) - q_init(k-1) )  &
369                       ) * dd2zu(k)
370             ENDIF
371
372             IF ( dissipation_1d == 'detering' )  THEN
373!
374!--             According to Detering, c_e=0.064
375                dissipation = 0.064_wp * e1d(k) * SQRT( e1d(k) ) / l1d(k)
376             ELSEIF ( dissipation_1d == 'as_in_3d_model' )  THEN
377                dissipation = ( 0.19_wp + 0.74_wp * l1d(k) / l_grid(k) )       &
378                              * e1d(k) * SQRT( e1d(k) ) / l1d(k)
379             ENDIF
380
381!
382!--          u-component
383             te_u(k) = f * ( v1d(k) - vg(k) ) + (                              &
384                       kmzp * ( u1d(k+1) - u1d(k) ) * ddzu(k+1) + usws1d       &
385                                                ) * 2.0_wp * ddzw(k)
386!
387!--          v-component
388             te_v(k) = -f * ( u1d(k) - ug(k) ) + (                             &
389                       kmzp * ( v1d(k+1) - v1d(k) ) * ddzu(k+1) + vsws1d       &
390                                                 ) * 2.0_wp * ddzw(k)
391!
392!--          TKE
393             te_e(k) = km1d(k) * ( ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2   &
394                                 + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2   &
395                                 )                                             &
396                                 - g / pt_0 * kh1d(k) * flux                   &
397                                 +           (                                 &
398                                  kmzp * ( e1d(k+1) - e1d(k) ) * ddzu(k+1)     &
399                                - kmzm * ( e1d(k) - e1d(k-1) ) * ddzu(k)       &
400                                              ) * ddzw(k)                      &
401                                - dissipation
402          ENDIF
403
404!
405!--       Prognostic equations for all 1D variables
406          DO  k = nzb+1, nzt
407
408             u1d_p(k) = u1d(k) + dt_1d * ( tsc(2) * te_u(k) + &
409                                           tsc(3) * te_um(k) )
410             v1d_p(k) = v1d(k) + dt_1d * ( tsc(2) * te_v(k) + &
411                                           tsc(3) * te_vm(k) )
412
413          ENDDO
414          IF ( .NOT. constant_diffusion )  THEN
415             DO  k = nzb+1, nzt
416
417                e1d_p(k) = e1d(k) + dt_1d * ( tsc(2) * te_e(k) + &
418                                              tsc(3) * te_em(k) )
419
420             ENDDO
421!
422!--          Eliminate negative TKE values, which can result from the
423!--          integration due to numerical inaccuracies. In such cases the TKE
424!--          value is reduced to 10 percent of its old value.
425             WHERE ( e1d_p < 0.0_wp )  e1d_p = 0.1_wp * e1d
426          ENDIF
427
428!
429!--       Calculate tendencies for the next Runge-Kutta step
430          IF ( timestep_scheme(1:5) == 'runge' ) THEN
431             IF ( intermediate_timestep_count == 1 )  THEN
432
433                DO  k = nzb+1, nzt
434                   te_um(k) = te_u(k)
435                   te_vm(k) = te_v(k)
436                ENDDO
437
438                IF ( .NOT. constant_diffusion )  THEN
439                   DO k = nzb+1, nzt
440                      te_em(k) = te_e(k)
441                   ENDDO
442                ENDIF
443
444             ELSEIF ( intermediate_timestep_count < &
445                         intermediate_timestep_count_max )  THEN
446
447                DO  k = nzb+1, nzt
448                   te_um(k) = -9.5625_wp * te_u(k) + 5.3125_wp * te_um(k)
449                   te_vm(k) = -9.5625_wp * te_v(k) + 5.3125_wp * te_vm(k)
450                ENDDO
451
452                IF ( .NOT. constant_diffusion )  THEN
453                   DO k = nzb+1, nzt
454                      te_em(k) = -9.5625_wp * te_e(k) + 5.3125_wp * te_em(k)
455                   ENDDO
456                ENDIF
457
458             ENDIF
459          ENDIF
460
461
462!
463!--       Boundary conditions for the prognostic variables.
464!--       At the top boundary (nzt+1) u,v and e keep their initial values
465!--       (ug(nzt+1), vg(nzt+1), 0), at the bottom boundary the mirror
466!--       boundary condition applies to u and v.
467!--       The boundary condition for e is set further below ( (u*/cm)**2 ).
468         ! u1d_p(nzb) = -u1d_p(nzb+1)
469         ! v1d_p(nzb) = -v1d_p(nzb+1)
470
471          u1d_p(nzb) = 0.0_wp
472          v1d_p(nzb) = 0.0_wp
473
474!
475!--       Swap the time levels in preparation for the next time step.
476          u1d  = u1d_p
477          v1d  = v1d_p
478          IF ( .NOT. constant_diffusion )  THEN
479             e1d  = e1d_p
480          ENDIF
481
482!
483!--       Compute diffusion quantities
484          IF ( .NOT. constant_diffusion )  THEN
485
486!
487!--          First compute the vertical fluxes in the Prandtl-layer
488             IF ( constant_flux_layer )  THEN
489!
490!--             Compute theta* using Rif numbers of the previous time step
491                IF ( rif1d(1) >= 0.0_wp )  THEN
492!
493!--                Stable stratification
494                   ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /          &
495                          ( LOG( zu(nzb+1) / z0h1d ) + 5.0_wp * rif1d(nzb+1) * &
496                                          ( zu(nzb+1) - z0h1d ) / zu(nzb+1)    &
497                          )
498                ELSE
499!
500!--                Unstable stratification
501                   a = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) )
502                   b = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /                 &
503                       zu(nzb+1) * z0h1d )
504!
505!--                In the borderline case the formula for stable stratification
506!--                must be applied, because otherwise a zero division would
507!--                occur in the argument of the logarithm.
508                   IF ( a == 0.0_wp  .OR.  b == 0.0_wp )  THEN
509                      ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /       &
510                             ( LOG( zu(nzb+1) / z0h1d ) +                      &
511                               5.0_wp * rif1d(nzb+1) *                         &
512                               ( zu(nzb+1) - z0h1d ) / zu(nzb+1)               &
513                             )
514                   ELSE
515                      ts1d = kappa * ( pt_init(nzb+1) - pt_init(nzb) ) /       &
516                             LOG( (a-1.0_wp) / (a+1.0_wp) *                    &
517                                  (b+1.0_wp) / (b-1.0_wp) )
518                   ENDIF
519                ENDIF
520
521             ENDIF    ! constant_flux_layer
522
523!
524!--          Compute the Richardson-flux numbers,
525!--          first at the top of the Prandtl-layer using u* of the previous
526!--          time step (+1E-30, if u* = 0), then in the remaining area. There
527!--          the rif-numbers of the previous time step are used.
528
529             IF ( constant_flux_layer )  THEN
530                IF ( .NOT. humidity )  THEN
531                   pt_0 = pt_init(nzb+1)
532                   flux = ts1d
533                ELSE
534                   pt_0 = pt_init(nzb+1) * ( 1.0_wp + 0.61_wp * q_init(nzb+1) )
535                   flux = ts1d + 0.61_wp * pt_init(k) * qs1d
536                ENDIF
537                rif1d(nzb+1) = zu(nzb+1) * kappa * g * flux / &
538                               ( pt_0 * ( us1d**2 + 1E-30_wp ) )
539             ENDIF
540
541             DO  k = nzb_diff, nzt
542                IF ( .NOT. humidity )  THEN
543                   pt_0 = pt_init(k)
544                   flux = ( pt_init(k+1) - pt_init(k-1) ) * dd2zu(k)
545                ELSE
546                   pt_0 = pt_init(k) * ( 1.0_wp + 0.61_wp * q_init(k) )
547                   flux = ( ( pt_init(k+1) - pt_init(k-1) )                    &
548                            + 0.61_wp * pt_init(k)                             &
549                            * ( q_init(k+1) - q_init(k-1) )                    &
550                          ) * dd2zu(k)
551                ENDIF
552                IF ( rif1d(k) >= 0.0_wp )  THEN
553                   rif1d(k) = g / pt_0 * flux /                                &
554                              (  ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2     &
555                               + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2     &
556                               + 1E-30_wp                                      &
557                              )
558                ELSE
559                   rif1d(k) = g / pt_0 * flux /                                &
560                              (  ( ( u1d(k+1) - u1d(k-1) ) * dd2zu(k) )**2     &
561                               + ( ( v1d(k+1) - v1d(k-1) ) * dd2zu(k) )**2     &
562                               + 1E-30_wp                                      &
563                              ) * ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
564                ENDIF
565             ENDDO
566!
567!--          Richardson-numbers must remain restricted to a realistic value
568!--          range. It is exceeded excessively for very small velocities
569!--          (u,v --> 0).
570             WHERE ( rif1d < zeta_min )  rif1d = zeta_min
571             WHERE ( rif1d > zeta_max )  rif1d = zeta_max
572
573!
574!--          Compute u* from the absolute velocity value
575             IF ( constant_flux_layer )  THEN
576                uv_total = SQRT( u1d(nzb+1)**2 + v1d(nzb+1)**2 )
577
578                IF ( rif1d(nzb+1) >= 0.0_wp )  THEN
579!
580!--                Stable stratification
581                   us1d = kappa * uv_total / (                                 &
582                             LOG( zu(nzb+1) / z01d ) + 5.0_wp * rif1d(nzb+1) * &
583                                              ( zu(nzb+1) - z01d ) / zu(nzb+1) &
584                                             )
585                ELSE
586!
587!--                Unstable stratification
588                   a = 1.0_wp / SQRT( SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) ) )
589                   b = 1.0_wp / SQRT( SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /  &
590                                                     zu(nzb+1) * z01d ) )
591!
592!--                In the borderline case the formula for stable stratification
593!--                must be applied, because otherwise a zero division would
594!--                occur in the argument of the logarithm.
595                   IF ( a == 1.0_wp  .OR.  b == 1.0_wp )  THEN
596                      us1d = kappa * uv_total / (                              &
597                             LOG( zu(nzb+1) / z01d ) +                         &
598                             5.0_wp * rif1d(nzb+1) * ( zu(nzb+1) - z01d ) /    &
599                                                  zu(nzb+1) )
600                   ELSE
601                      us1d = kappa * uv_total / (                              &
602                                 LOG( (1.0_wp+b) / (1.0_wp-b) * (1.0_wp-a) /   &
603                                      (1.0_wp+a) ) +                           &
604                                 2.0_wp * ( ATAN( b ) - ATAN( a ) )            &
605                                                )
606                   ENDIF
607                ENDIF
608
609!
610!--             Compute the momentum fluxes for the diffusion terms
611                usws1d  = - u1d(nzb+1) / uv_total * us1d**2
612                vsws1d  = - v1d(nzb+1) / uv_total * us1d**2
613
614!
615!--             Boundary condition for the turbulent kinetic energy at the top
616!--             of the Prandtl-layer. c_m = 0.4 according to Detering.
617!--             Additional Neumann condition de/dz = 0 at nzb is set to ensure
618!--             compatibility with the 3D model.
619                IF ( ibc_e_b == 2 )  THEN
620                   e1d(nzb+1) = ( us1d / 0.1_wp )**2
621!                  e1d(nzb+1) = ( us1d / 0.4_wp )**2  !not used so far, see also
622                                                      !prandtl_fluxes
623                ENDIF
624                e1d(nzb) = e1d(nzb+1)
625
626                IF ( humidity ) THEN
627!
628!--                Compute q*
629                   IF ( rif1d(1) >= 0.0_wp )  THEN
630!
631!--                   Stable stratification
632                      qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /         &
633                          ( LOG( zu(nzb+1) / z0h1d ) + 5.0_wp * rif1d(nzb+1) * &
634                                          ( zu(nzb+1) - z0h1d ) / zu(nzb+1)    &
635                          )
636                   ELSE
637!
638!--                   Unstable stratification
639                      a = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) )
640                      b = SQRT( 1.0_wp - 16.0_wp * rif1d(nzb+1) /              &
641                                         zu(nzb+1) * z0h1d )
642!
643!--                   In the borderline case the formula for stable stratification
644!--                   must be applied, because otherwise a zero division would
645!--                   occur in the argument of the logarithm.
646                      IF ( a == 1.0_wp  .OR.  b == 1.0_wp )  THEN
647                         qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /      &
648                                ( LOG( zu(nzb+1) / z0h1d ) +                   &
649                                  5.0_wp * rif1d(nzb+1) *                      &
650                                  ( zu(nzb+1) - z0h1d ) / zu(nzb+1)            &
651                                )
652                      ELSE
653                         qs1d = kappa * ( q_init(nzb+1) - q_init(nzb) ) /      &
654                                LOG( (a-1.0_wp) / (a+1.0_wp) *                 &
655                                     (b+1.0_wp) / (b-1.0_wp) )
656                      ENDIF
657                   ENDIF               
658                ELSE
659                   qs1d = 0.0_wp
660                ENDIF             
661
662             ENDIF   !  constant_flux_layer
663
664!
665!--          Compute the diabatic mixing length
666             IF ( mixing_length_1d == 'blackadar' )  THEN
667                DO  k = nzb+1, nzt
668                   IF ( rif1d(k) >= 0.0_wp )  THEN
669                      l1d(k) = l_black(k) / ( 1.0_wp + 5.0_wp * rif1d(k) )
670                   ELSE
671                      l1d(k) = l_black(k) *                                    &
672                               ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
673                   ENDIF
674                   l1d(k) = l_black(k)
675                ENDDO
676
677             ELSEIF ( mixing_length_1d == 'as_in_3d_model' )  THEN
678                DO  k = nzb+1, nzt
679                   dpt_dz = ( pt_init(k+1) - pt_init(k-1) ) * dd2zu(k)
680                   IF ( dpt_dz > 0.0_wp )  THEN
681                      l_stable = 0.76_wp * SQRT( e1d(k) ) /                    &
682                                     SQRT( g / pt_init(k) * dpt_dz ) + 1E-5_wp
683                   ELSE
684                      l_stable = l_grid(k)
685                   ENDIF
686                   l1d(k) = MIN( l_grid(k), l_stable )
687                ENDDO
688             ENDIF
689
690!
691!--          Compute the diffusion coefficients for momentum via the
692!--          corresponding Prandtl-layer relationship and according to
693!--          Prandtl-Kolmogorov, respectively. The unstable stratification is
694!--          computed via the adiabatic mixing length, for the unstability has
695!--          already been taken account of via the TKE (cf. also Diss.).
696             IF ( constant_flux_layer )  THEN
697                IF ( rif1d(nzb+1) >= 0.0_wp )  THEN
698                   km1d(nzb+1) = us1d * kappa * zu(nzb+1) /                    &
699                                 ( 1.0_wp + 5.0_wp * rif1d(nzb+1) )
700                ELSE
701                   km1d(nzb+1) = us1d * kappa * zu(nzb+1) *                    &
702                                 ( 1.0_wp - 16.0_wp * rif1d(nzb+1) )**0.25_wp
703                ENDIF
704             ENDIF
705             DO  k = nzb_diff, nzt
706!                km1d(k) = 0.4 * SQRT( e1d(k) ) !changed: adjustment to 3D-model
707                km1d(k) = 0.1_wp * SQRT( e1d(k) )
708                IF ( rif1d(k) >= 0.0_wp )  THEN
709                   km1d(k) = km1d(k) * l1d(k)
710                ELSE
711                   km1d(k) = km1d(k) * l_black(k)
712                ENDIF
713             ENDDO
714
715!
716!--          Add damping layer
717             DO  k = damp_level_ind_1d+1, nzt+1
718                km1d(k) = 1.1_wp * km1d(k-1)
719                km1d(k) = MIN( km1d(k), 10.0_wp )
720             ENDDO
721
722!
723!--          Compute the diffusion coefficient for heat via the relationship
724!--          kh = phim / phih * km
725             DO  k = nzb+1, nzt
726                IF ( rif1d(k) >= 0.0_wp )  THEN
727                   kh1d(k) = km1d(k)
728                ELSE
729                   kh1d(k) = km1d(k) * ( 1.0_wp - 16.0_wp * rif1d(k) )**0.25_wp
730                ENDIF
731             ENDDO
732
733          ENDIF   ! .NOT. constant_diffusion
734
735       ENDDO   ! intermediate step loop
736
737!
738!--    Increment simulated time and output times
739       current_timestep_number_1d = current_timestep_number_1d + 1
740       simulated_time_1d          = simulated_time_1d + dt_1d
741       simulated_time_chr         = time_to_string( simulated_time_1d )
742       time_pr_1d                 = time_pr_1d          + dt_1d
743       time_run_control_1d        = time_run_control_1d + dt_1d
744
745!
746!--    Determine and print out quantities for run control
747       IF ( time_run_control_1d >= dt_run_control_1d )  THEN
748          CALL run_control_1d
749          time_run_control_1d = time_run_control_1d - dt_run_control_1d
750       ENDIF
751
752!
753!--    Profile output on file
754       IF ( time_pr_1d >= dt_pr_1d )  THEN
755          CALL print_1d_model
756          time_pr_1d = time_pr_1d - dt_pr_1d
757       ENDIF
758
759!
760!--    Determine size of next time step
761       CALL timestep_1d
762
763    ENDDO   ! time loop
764
765
766 END SUBROUTINE time_integration_1d
767
768
769!------------------------------------------------------------------------------!
770! Description:
771! ------------
772!> Compute and print out quantities for run control of the 1D model.
773!------------------------------------------------------------------------------!
774 
775 SUBROUTINE run_control_1d
776
777
778    USE constants,                                                             &
779        ONLY:  pi
780       
781    USE indices,                                                               &
782        ONLY:  nzb, nzt
783       
784    USE kinds
785   
786    USE model_1d,                                                              &
787        ONLY:  current_timestep_number_1d, dt_1d, run_control_header_1d, u1d,  &
788               us1d, v1d
789   
790    USE pegrid
791   
792    USE control_parameters,                                                    &
793        ONLY:  simulated_time_chr
794
795    IMPLICIT NONE
796
797    INTEGER(iwp) ::  k  !<
798   
799    REAL(wp) ::  alpha 
800    REAL(wp) ::  energy 
801    REAL(wp) ::  umax
802    REAL(wp) ::  uv_total 
803    REAL(wp) ::  vmax
804
805!
806!-- Output
807    IF ( myid == 0 )  THEN
808!
809!--    If necessary, write header
810       IF ( .NOT. run_control_header_1d )  THEN
811          CALL check_open( 15 )
812          WRITE ( 15, 100 )
813          run_control_header_1d = .TRUE.
814       ENDIF
815
816!
817!--    Compute control quantities
818!--    grid level nzp is excluded due to mirror boundary condition
819       umax = 0.0_wp; vmax = 0.0_wp; energy = 0.0_wp
820       DO  k = nzb+1, nzt+1
821          umax = MAX( ABS( umax ), ABS( u1d(k) ) )
822          vmax = MAX( ABS( vmax ), ABS( v1d(k) ) )
823          energy = energy + 0.5_wp * ( u1d(k)**2 + v1d(k)**2 )
824       ENDDO
825       energy = energy / REAL( nzt - nzb + 1, KIND=wp )
826
827       uv_total = SQRT( u1d(nzb+1)**2 + v1d(nzb+1)**2 )
828       IF ( ABS( v1d(nzb+1) ) < 1.0E-5_wp )  THEN
829          alpha = ACOS( SIGN( 1.0_wp , u1d(nzb+1) ) )
830       ELSE
831          alpha = ACOS( u1d(nzb+1) / uv_total )
832          IF ( v1d(nzb+1) <= 0.0_wp )  alpha = 2.0_wp * pi - alpha
833       ENDIF
834       alpha = alpha / ( 2.0_wp * pi ) * 360.0_wp
835
836       WRITE ( 15, 101 )  current_timestep_number_1d, simulated_time_chr, &
837                          dt_1d, umax, vmax, us1d, alpha, energy
838!
839!--    Write buffer contents to disc immediately
840       FLUSH( 15 )
841
842    ENDIF
843
844!
845!-- formats
846100 FORMAT (///'1D-Zeitschrittkontrollausgaben:'/ &
847              &'------------------------------'// &
848           &'ITER.  HH:MM:SS    DT      UMAX   VMAX    U*   ALPHA   ENERG.'/ &
849           &'-------------------------------------------------------------')
850101 FORMAT (I5,2X,A9,1X,F6.2,2X,F6.2,1X,F6.2,1X,F6.3,2X,F5.1,2X,F7.2)
851
852
853 END SUBROUTINE run_control_1d
854
855
856
857!------------------------------------------------------------------------------!
858! Description:
859! ------------
860!> Compute the time step w.r.t. the diffusion criterion
861!------------------------------------------------------------------------------!
862 
863 SUBROUTINE timestep_1d
864
865
866    USE arrays_3d,                                                             &
867        ONLY:  dzu, zu
868       
869    USE indices,                                                               &
870        ONLY:  nzb, nzt
871   
872    USE kinds
873   
874    USE model_1d,                                                              &
875        ONLY:  dt_1d, dt_max_1d, km1d, old_dt_1d, stop_dt_1d
876   
877    USE pegrid
878   
879    USE control_parameters,                                                    &
880        ONLY:  message_string
881
882    IMPLICIT NONE
883
884    INTEGER(iwp) ::  k !<
885   
886    REAL(wp) ::  div      !<
887    REAL(wp) ::  dt_diff  !<
888    REAL(wp) ::  fac      !<
889    REAL(wp) ::  value    !<
890
891
892!
893!-- Compute the currently feasible time step according to the diffusion
894!-- criterion. At nzb+1 the half grid length is used.
895    fac = 0.35_wp
896    dt_diff = dt_max_1d
897    DO  k = nzb+2, nzt
898       value   = fac * dzu(k) * dzu(k) / ( km1d(k) + 1E-20_wp )
899       dt_diff = MIN( value, dt_diff )
900    ENDDO
901    value   = fac * zu(nzb+1) * zu(nzb+1) / ( km1d(nzb+1) + 1E-20_wp )
902    dt_1d = MIN( value, dt_diff )
903
904!
905!-- Set flag when the time step becomes too small
906    IF ( dt_1d < ( 0.00001_wp * dt_max_1d ) )  THEN
907       stop_dt_1d = .TRUE.
908
909       WRITE( message_string, * ) 'timestep has exceeded the lower limit &', &
910                                  'dt_1d = ',dt_1d,' s   simulation stopped!'
911       CALL message( 'timestep_1d', 'PA0192', 1, 2, 0, 6, 0 )
912       
913    ENDIF
914
915!
916!-- A more or less simple new time step value is obtained taking only the
917!-- first two significant digits
918    div = 1000.0_wp
919    DO  WHILE ( dt_1d < div )
920       div = div / 10.0_wp
921    ENDDO
922    dt_1d = NINT( dt_1d * 100.0_wp / div ) * div / 100.0_wp
923
924    old_dt_1d = dt_1d
925
926
927 END SUBROUTINE timestep_1d
928
929
930
931!------------------------------------------------------------------------------!
932! Description:
933! ------------
934!> List output of profiles from the 1D-model
935!------------------------------------------------------------------------------!
936 
937 SUBROUTINE print_1d_model
938
939
940    USE arrays_3d,                                                             &
941        ONLY:  pt_init, zu
942       
943    USE indices,                                                               &
944        ONLY:  nzb, nzt
945       
946    USE kinds
947   
948    USE model_1d,                                                              &
949        ONLY:  e1d, kh1d, km1d, l1d, rif1d, u1d, v1d
950   
951    USE pegrid
952   
953    USE control_parameters,                                                    &
954        ONLY:  run_description_header, simulated_time_chr
955
956    IMPLICIT NONE
957
958
959    INTEGER(iwp) ::  k  !<
960
961
962    IF ( myid == 0 )  THEN
963!
964!--    Open list output file for profiles from the 1D-model
965       CALL check_open( 17 )
966
967!
968!--    Write Header
969       WRITE ( 17, 100 )  TRIM( run_description_header ), &
970                          TRIM( simulated_time_chr )
971       WRITE ( 17, 101 )
972
973!
974!--    Write the values
975       WRITE ( 17, 102 )
976       WRITE ( 17, 101 )
977       DO  k = nzt+1, nzb, -1
978          WRITE ( 17, 103)  k, zu(k), u1d(k), v1d(k), pt_init(k), e1d(k), &
979                            rif1d(k), km1d(k), kh1d(k), l1d(k), zu(k), k
980       ENDDO
981       WRITE ( 17, 101 )
982       WRITE ( 17, 102 )
983       WRITE ( 17, 101 )
984
985!
986!--    Write buffer contents to disc immediately
987       FLUSH( 17 )
988
989    ENDIF
990
991!
992!-- Formats
993100 FORMAT (//1X,A/1X,10('-')/' 1d-model profiles'/ &
994            ' Time: ',A)
995101 FORMAT (1X,79('-'))
996102 FORMAT ('   k     zu      u      v     pt      e    rif    Km    Kh     ', &
997            'l      zu      k')
998103 FORMAT (1X,I4,1X,F7.1,1X,F6.2,1X,F6.2,1X,F6.2,1X,F6.2,1X,F5.2,1X,F5.2, &
999            1X,F5.2,1X,F6.2,1X,F7.1,2X,I4)
1000
1001
1002 END SUBROUTINE print_1d_model
Note: See TracBrowser for help on using the repository browser.