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

Last change on this file since 1346 was 1346, checked in by heinze, 10 years ago

Bugfix: REAL constants provided with KIND-attribute especially in call of intrinsic function like MAX, MIN, SIGN

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