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

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

last commit documented

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