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

Last change on this file since 1017 was 1017, checked in by raasch, 9 years ago

last commit documented

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