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

Last change on this file since 2101 was 2101, checked in by suehring, 5 years ago

last commit documented

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