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

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