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

Last change on this file since 1952 was 1818, checked in by maronga, 8 years ago

last commit documented / copyright update

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